สอบถามเรื่องข้อมูลเยอะมาก ทำให้ vba ทำงานช้ามาก

[snasui]

งานนี้ผู้ถามต้องการทราบวิธีการแปลง Sub Procedure เป็นฟังก์ชั่น Procedure ว่าแปลงได้หรือไม่ มีลักษณะเป็นอย่างไรซึ่งคงพิจารณาประกอบเองเพิ่มเติมว่าสะดวกแบบไหนมากกว่ากันครับ

การให้แสดงพร้อมกันทุกตัวก็สามารถทำได้เช่นกัน คือคลุมพื้นที่ เขียนสูตรแล้วกดแป้น Ctrl+Shift+Enter ไม่ต้องใช้ Index เข้าไปครอบ ซึ่งก็ต้องกันพื้นที่ที่จะทำเช่นนั้นครับ

ผมเห็นว่าการเปิด-ปิดไฟล์เป็นประเด็นหลักมากกว่าที่จะให้แสดงค่าออกมาพร้อมกันทั้งหมด เพราะการทำงานแบบนี้ย่อมต้องเตรียมพื้นที่เอาไว้แสดงผลอยู่แล้วไม่ว่าจะด้วย Sub Procedure หรือ Function Procedure หรือ Spill Array แบบ Office 365 ก็ตาม

การใช้ Index เข้าไปช่วยเป็นการอธิบายเพื่อความเข้าใจว่ามันสามารถปรับอย่างไรเพื่อให้แสดงผลทีละตัวได้ครับ

[lnongkungl]

ขอบคุณอาจารย์ทั้ง 2 ท่านครับ ผมจะนำไปศึกษาเพิ่มเติมครับ

[lnongkungl]

อาจารย์ครับ ผมลอง run function ดูแล้ว ผลที่มาภาพรวมถูกต้อง แต่ผลลัพท์ที่แสดงไม่ครบครับ
ผมลองใส่เลขที่ต้องการค้นหา ผลลัพท์จริงๆจะมีประมาณ 4 วัน แต่ผลลัพท์ที่แสดงออกมาแค่วันเดียวคือวันแรกที่ค้าหาเจอ ส่วนอีก 3 วันต่อมา ไม่มีข้อมูลแสดงครับ

เป็นเพราะตอนท้าย code เราให้ function = a เลยหรือปล่าวครับ ไม่ได้ขยายแถว resize(1,51) ให้เลยแสดงผลลัพท์แค่ cell เดียว ผมเข้าใจถูกหรือไม่ครับ

[snasui]

เข้าใจว่าไม่ใด้ใช้ Excel 365 หากเป็น Excel 365 จึงจะคีย์สูตรในเซลล์เริ่มต้นเซลล์เดียวได้ครับ

การคีย์สูตรเพื่อให้แสดงผลลัพธ์หลายค่าใน Excel Version อื่น ๆ ให้คลุมพื้นที่เอาไว้ก่อน > คีย์สูตร > Ctrl+Shfit+Enter

ลองทำตามลำดับดังนี้ครับ

1. เซลล์ B1 คีย์ Path ให้มีนามสกุลไฟล์ด้วย
2. ปรับ Code เป็นด้านล่าง

   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 Function

3. ที่ B3 คีย์
   =COUNTA(SearchContact_Func(B1,B2))
   Enter
4. คลุมที่ A6:A20 (สามารถคลุมพื้นที่ไว้ตามที่คิดว่าข้อมูลขยายไปถึง) คีย์
   =IF(ROW(1:1000)>B3,"",SearchContact_Func(B1,B2))
   Ctrl+Shift+Enter

กรุณา Update Version ของ Excel ที่ใช้ในปัจจุบันตาม Link นี้ด้วยครับ https://snasui.com/viewtopic.php?f=6&p=103177#p103177

[lnongkungl]

ขอบคุณครับ อาจารย์ ผม update version ของ excel แล้วครับ และจะลองนำคำแนะนำไปลองปรับใช้งานดูครับ

[lnongkungl]

น่าจะเป็นประเด็นสุดท้ายละครับ แต่ยาวหน่อย
ผมลองทำตามคำแนะนำที่อาจารย์บอกครับ ผลก็ได้ตามความต้องการ ทีนี้มาถึงขั้นตอนสุดท้ายคือ นำคำตอบที่ได้มารวมกันให้เป็น cell เดียว และ คีย์ function ครั้งเดียวให้ได้ผลลัพธ์เลย ผมเลยไปค้นหาวิธีรวมข้อมุลให้เป็น cell เดียวกันมาใส่ แต่แยกเป็นคนละ function แล้วก็เอา =COUNTA(SearchContact_Func(B1,B2)) ไปใส่ใน function เดิม ก็จะเหลือ 2 ขั้นตอน คือ =IF(ROW(1:1000)>B3,"",SearchContact_Func(B1,B2)) กับ function concatrange ที่ผมเพิ่มเข้าไป

เรียนตามตรงครับ ผมพยายามเอา 2 ขั้นตอนนี้ มารวมกัน โดยตอนแรกเอา =IF(ROW(1:1000)>B3,"",SearchContact_Func(B1,B2)) พยายามยัดเข้าไปใน function แล้วก็เอา concatrange มาต่อกัน ผลสุดท้าย code มั่วไม่ใช่แค่ error อย่างเดียว ค้างไปเลยครับ สุดท้ายลบที่เพิ่มเข้าไปจนเหลือแค่ 2 ตัวแปลสุดท้าย code ถึง run ต่อได้

Code: Select all

'
'
'
Dim fs As Variant
Dim nb As Integer
    fs = Application.Transpose(a)
    nb = Application.CountA(fs)

    
    SearchContact_Func = nb
'
'
'

จนปัญญาจริงๆครับ รบกวนขอแนวทางด้วยครับอาจารย์

[snasui]

ตัวอย่าง Funtion ที่ให้ผลลัพธ์เป็นสายอักขระพร้อมปรับ Performance ให้ดีกว่าเดิมครับ

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 Function

เขียนสูตรที่เซลล์ใด ๆ เป็น

=SearchContact_Func_Join(B1,B2)

Enter

[Bo_ry]

UDF

Code: 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

[lnongkungl]

ขอบคุณอาจารย์ทั้ง 2 ท่านครับ ติดประเด็นอะไรอีก จะเข้ามาขออนุญาติรบกวนสอบถามอีกนะครับ

ผมอยากรบกวนอาจารย์แนะนำหนังสือหรือ e-book เกี่ยวกับการเขียน VBA ให้ผมหน่อยครับ ผมจะได้ไปหาซื้อเอามาศึกษาเพิ่มพูนความรู้ให้ดียิ่งขึ้นกว่านี้ครับ เพราะบางทีเข้าไปหาข้อมูลจากที่อื่น หรือ ที่อาจารย์ตอบใน forum เจอ code บางตัวที่ไม่เคยเห็น ก็ไม่เข้าใจว่าคำสั่งของ code นั้นคืออะไรครับ

ขอบคุณครับ

[snasui]

ลองศึกษาดูตาม Link นี้ของ Microsoft ดูครับ https://docs.microsoft.com/en-us/office ... -reference

กรณีเป็นหนังสือ ลองดูตาม Link นี้ครับ Power Programming with VBA

[lnongkungl]

อาจารย์ครับ อีกนิดนึงครับ เราสามารถใส่อธิบายฟังก์ชั่น แบบรูปแนบได้มั้ยครับ ผมพยายามหาวิธีทำ แต่ค้นหาไม่เจอ ครับ

[snasui]

ไม่สามารถทำได้ด้วย VBA ครับ

ฟังก์ชั่น Tooltips ต้องใช้เครื่องมือชนิดอื่นเข้ามาช่วย

ภาพด้านล่างผมเขียนด้วย Visual Studio โดยใช้ Extension ที่ชื่อว่า Excel DNA เข้ามาช่วยครับ