ตรวจสอบและปรับปรุงไฟล์ Excel ให้เร็วและเสถียรด้วย File Anatomy Add-in
เครื่องมือนี้ช่วยวิเคราะห์โครงสร้างไฟล์อย่างละเอียด เช่น สูตร, ลิงก์, PivotTable, Styles และ Objects
พร้อมฟังก์ชันล้างสิ่งเกินจำเป็นที่ทำให้ไฟล์ช้า หรือเสียหายได้ในคลิกเดียว
เหมาะสำหรับผู้ใช้ Excel ที่ต้องการควบคุมคุณภาพไฟล์อย่างมืออาชีพ
ทดลองใช้ Add-in
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
ระบุ Version ของ Excel 
โปรดทราบ สมัครสมาชิก
Login ผ่าน Facebook Reset รหัสผ่าน ติดต่อผู้ดูแลระบบ ตั้งค่าส่วนตัว วิธีการตั้งและตอบกระทู้ จัดรูปแบบตัวอักษร กำหนดขนาดตัวอักษรใน Browser[code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
งานนี้ผู้ถามต้องการทราบวิธีการแปลง Sub Procedure เป็นฟังก์ชั่น Procedure ว่าแปลงได้หรือไม่ มีลักษณะเป็นอย่างไรซึ่งคงพิจารณาประกอบเองเพิ่มเติมว่าสะดวกแบบไหนมากกว่ากันครับ
test P1-2021.xlsx testfunction.xlsm เข้าใจว่าไม่ใด้ใช้ Excel 365 หากเป็น Excel 365 จึงจะคีย์สูตรในเซลล์เริ่มต้นเซลล์เดียวได้ครับCode: Select all
Function SearchContact_Func(f As Range, c As Range) As Variant
Dim s As String
Dim r As Range, v As String
Dim wb As Workbook
Dim source As Range
Dim a() As Variant
Dim i As Long
Dim xlApp As Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Sheet1")
s = LCase(c.Value)
Set wb = xlApp.Workbooks.Open(Filename:=f.Value, ReadOnly:=True)
End With
j = 0
With wb.Sheets(1)
.Range("a3").CurrentRegion.EntireRow.Hidden = False
For Each r In .Range("a8", .Range("a" & .Rows.Count).End(xlUp))
v = VBA.Join(Application.Transpose( _
Application.Transpose(Application.Index(r.Resize(1, 51), 0))))
v = LCase(v)
If v Like "*" & s & "*" Then
ReDim Preserve a(j)
a(j) = r.Value
j = j + 1
End If
Next r
End With
wb.Close False
SearchContact_Func = Application.Transpose(a)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End FunctionCode: Select all
'
'
'
Dim fs As Variant
Dim nb As Integer
fs = Application.Transpose(a)
nb = Application.CountA(fs)
SearchContact_Func = nb
'
'
'Code: Select all
Function SearchContact_Func_join(f As Range, c As Range) As String
Dim s As String, a() As Variant, b As Variant
Dim xlApp As Application, wb As Workbook
Dim i As Long, j As Long, k As Long
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Sheet1")
s = LCase(c.Value)
Set wb = xlApp.Workbooks.Open(Filename:=f.Value, ReadOnly:=True)
End With
j = 0
With wb.Sheets(1)
.Range("a3").CurrentRegion.EntireRow.Hidden = False
b = .Range("a8", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 51)
For i = 1 To UBound(b)
For k = 1 To 51
If InStr(LCase(b(i, k)), s) Then
ReDim Preserve a(j)
a(j) = b(i, 1)
j = j + 1
Exit For
End If
Next k
Next i
End With
wb.Close False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
SearchContact_Func_join = VBA.Join(a, ",")
End FunctionCode: Select all
Function SJ(f As Range, c As Range) As String
Dim a, l As Long, wb As Workbook, j As String, Ap As Application
Application.ScreenUpdating = False
Set Ap = CreateObject("Excel.Application")
Set wb = Ap.Workbooks.Open(Filename:=f.Value, ReadOnly:=True)
With wb.Sheets(1)
l = .Cells(Rows.Count, 1).End(xlUp)
a = .Evaluate(Replace("Transpose(IF(MMULT(N(ISNUMBER(SEARCH(""" & c & """,B8:AY#))),TRANSPOSE(COLUMN(B1:AY1)^0)),A8:$A#))", "#", l))
End With
wb.Close
a = Filter(a, False, False)
For l = 0 To UBound(a)
j = j & "," & Application.Text(a(l), "d-mmm-yy;;")
Next
SJ = Mid(j, 2)
Application.ScreenUpdating = True
End Function