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

[lnongkungl]

สวัสดีครับอาจารย์ และผู้ให้ความรู้ทุกท่าน ผมรบกวนขอความช่วยเหลือในเรื่องการ run code ช้ามากๆ เพราะข้อมูลเยอะ และการ copy โดยที่ไม่เอาข้อมูลที่ hide ไว้ครับ

ขอเกริ่นการทำงานก่อนนะครับ ผมแนบไฟล์มา 2 ไฟล์ คือ
1. ContactNo เป็นตัว runcode และวางข้อมูล
2. test P1-2021 ซึ่งเป็นไฟล์จำลองมาให้ทดสอบ code ครับ (ไฟล์จริงใหญ่มาก ข้อมูลใหญ่เกินไฟล์แนบ)

การทำงานคือ จะใส่ชื่อและที่อยู่ไฟล์ใน cell B3 เพื่อเป็นตัวเปิดไฟล์ข้อมูลครับ และ ใน cell B1 เป็นตัวอ้างอิงค้นหาข้อมูลในไฟล์ที่ 2 และเมื่อค้นหาเสร็จก็ทำการ copy ข้อมูลใน colume a มาวางใน cell A10 ของไฟล์แรก ซึ่งผมลองเขียน code แล้วทำงานได้ปกติตามต้องการ แต่...

1.ไฟล์จริงซึ่งมีขนาดใหญ่มาก จึงทำให้ใช้เวลาในการค้นหาและซ่อนแถวที่ไม่ใช้นานมากมีวิธีปรับ code ให้ทำการค้นหาได้เร็วขึ้นมั้ยครับ
2. เมื่อทำการค้นหาเสร็จแล้ว ซ่อนแถวที่ไม่ใช้ไว้ แต่เมื่อ copy ข้อมูลมาวาง มันมาทั้งหมดครับ ไม่ได้มาเฉพาะ cell ที่แสดง ถ้าเป็น manaul คือ กด F5 แล้วเลือก specail > visible cells only ได้ แต่ code vba ผมพยายามหาข้อมูลแล้วครับ แต่ไม่เจอจริงๆ
3. ไฟล์จริงจะมีข้อมูลย้อนหลังของปีเก่าอยู่ด้วย สามารถปรับ code ให้ค้นหาเฉพาะของปีปัจจุบันได้มั้ยครับ โดยอ้างอิงจาก colume a ซึ่งเป็นวันที่อยู่แล้ว

Code: Select all

Sub SearchContact()
Dim s As String
s = LCase(Range("b1").Value)

Workbooks.Open Range("B3").Value & ".xlsx"
    Dim r As Range, v As String
    With Sheets("production plan   ")
        .Range("a3").CurrentRegion.EntireRow.Hidden = False
        For Each r In .Range("a8", .Range("a" & .Rows.Count).End(xlUp))
            v = ""
            v = v & r.Value
            v = v & r.Offset(0, 1).Value
            v = v & r.Offset(0, 2).Value
            v = v & r.Offset(0, 3).Value
            v = v & r.Offset(0, 4).Value
            v = v & r.Offset(0, 5).Value
            v = v & r.Offset(0, 6).Value
            v = v & r.Offset(0, 7).Value
            v = v & r.Offset(0, 8).Value
            v = v & r.Offset(0, 5).Value
            v = v & r.Offset(0, 6).Value
            v = v & r.Offset(0, 7).Value
            v = v & r.Offset(0, 8).Value
            v = v & r.Offset(0, 9).Value
            v = v & r.Offset(0, 10).Value
            v = v & r.Offset(0, 11).Value
            v = v & r.Offset(0, 12).Value
            v = v & r.Offset(0, 13).Value
            v = v & r.Offset(0, 14).Value
            v = v & r.Offset(0, 15).Value
             v = v & r.Offset(0, 16).Value
            v = v & r.Offset(0, 17).Value
            v = v & r.Offset(0, 18).Value
             v = v & r.Offset(0, 19).Value
            v = v & r.Offset(0, 20).Value
            v = v & r.Offset(0, 21).Value
            v = v & r.Offset(0, 22).Value
             v = v & r.Offset(0, 23).Value
             v = v & r.Offset(0, 24).Value
             v = v & r.Offset(0, 25).Value
             v = v & r.Offset(0, 26).Value
             v = v & r.Offset(0, 27).Value
             v = v & r.Offset(0, 28).Value
             v = v & r.Offset(0, 29).Value
             v = v & r.Offset(0, 30).Value
            v = v & r.Offset(0, 31).Value
            v = v & r.Offset(0, 32).Value
            v = v & r.Offset(0, 33).Value
            v = v & r.Offset(0, 34).Value
            v = v & r.Offset(0, 35).Value
            v = v & r.Offset(0, 36).Value
            v = v & r.Offset(0, 37).Value
             v = v & r.Offset(0, 38).Value
            v = v & r.Offset(0, 39).Value
            v = v & r.Offset(0, 40).Value
             v = v & r.Offset(0, 41).Value
            v = v & r.Offset(0, 42).Value
             v = v & r.Offset(0, 43).Value
             v = v & r.Offset(0, 44).Value
             v = v & r.Offset(0, 45).Value
            v = v & r.Offset(0, 46).Value
             v = v & r.Offset(0, 47).Value
            v = v & r.Offset(0, 48).Value
             v = v & r.Offset(0, 49).Value
             v = v & r.Offset(0, 50).Value
            v = LCase(v)
            If Not v Like "*" & s & "*" Then
                r.EntireRow.Hidden = True
            End If
        Next r
        
        Dim source As Range
        Set source = Range("A8", .Range("A" & .Rows.Count).End(xlUp))
        source.Copy
    End With
    
    Workbooks("ContactNo.xlsm").Activate
    Range("A10").PasteSpecial xlPasteValues
    Application.CutCopyMode = fasle
    
End Sub

รบกวนขอคำแนะนำด้วยครับ ขอบคุณครับ

[snasui]

ปกติควรทำเป็นตัวอย่างไฟล์มาตามกฎการใช้บอร์ดข้อ 4 ด้านบน ที่ทำมานั้นถือว่าตรงตามกฎแล้วครับ

ตัวอย่างการปรับ Code ดูตามด้านล่าง ลองนำไปปรับใช้กับการหาปีปัจจุบัน ติดตรงไหนค่อยนำมาถามกันต่อครับ

Code: Select all

Sub SearchContact()
    Dim s As String
    Dim r As Range, v As String
    Dim wb As Workbook
    Dim source As Range
    Dim a(999999, 50) As Variant
    Dim i As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Worksheets("Sheet1")
        s = LCase(.Range("b1").Value)
        Set wb = Workbooks.Open(Filename:=.Range("B3").Value & ".xlsx", ReadOnly:=True)
    End With
    j = 0
    With wb.Sheets("production plan   ")
        .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
                For i = 0 To 50
                    a(j, i) = r.Offset(0, i).Value
                Next i
                j = j + 1
            End If
        Next r
    End With
    wb.Close False
    ThisWorkbook.Worksheets("Sheet1").Range("A10").Resize(j, 51) = a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Finished.", vbInformation
End Sub

[lnongkungl]

ขอบคุณครับอาจารย์ ผลลัพท์ออกมาเกินกว่าที่ต้องการ
1. ต้องการดึงข้อมูลมาเพียงแค่วันที่ใน colume a ครับ แต่ผมลองปรับค่าบรรทัดนี้ ก็ได้ผลลัพท์ที่ต้อง

Code: Select all

ThisWorkbook.Worksheets("Sheet1").Range("A10").Resize(j, 1) = a

ผมปรับถูกตำแหน่งหรือไม่ครับ

2. ข้อมูลที่ดึงมาแสดง ยังมีข้อมูลของปีเก่ามาด้วย อันนี้ไม่เป็นไรครับ เพราะไฟล์ข้อมูลจะทำการลบประวัติของเดิมออกทุกๆ 6 เดือน
3. รบกวนอาจารย์ อธิบาย code ตรงนี้ให้ทีครับ เป็น function ที่ผมไม่เคยใช้ เลยยังไม่ค่อยเข้าใจครับ จะได้นำไปประยุกต์ใช้ในโอกาสต่อไปครับ

Code: Select all

v = VBA.Join(Application.Transpose( _
                Application.Transpose(Application.Index(r.Resize(1, 51), 0))))

ขอบคุณครับ

[lnongkungl]

เจอปัญหาใหม่ครับ เมื่อทดลองใส่ ข้อมูลที่ผิด หรือไม่มี contract no นั้น เข้าไป พบว่า code error ที่ บรรทัดนี้ครับ

Code: Select all

ThisWorkbook.Worksheets("Sheet1").Range("A5").Resize(j, 51) = a

ผมจึงเข้าใจว่า ค่า a ที่เก็บข้อมูล ไม่เจอผลลัพท์ เลย error ผมเลยแทรก if เข้าไป ถ้าไม่เจอข้อมูล ให้แจ้งว่า ไม่มีข้อมูล พอรัน error mismacth ครับ หรือผมเข้าใจผิดตรงไหนครับ

Code: Select all

Sub SearchContact()
    Dim s As String
    Dim r As Range, v As String
    Dim wb As Workbook
    Dim source As Range
    Dim a(999999, 50) As Variant
    Dim i As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Worksheets("Sheet1")
        s = LCase(.Range("b2").Value)
        Set wb = Workbooks.Open(Filename:=.Range("B1").Value & ".xlsx", ReadOnly:=True)
    End With
    j = 0
    With wb.Sheets("production plan   ")
        .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
                For i = 0 To 50
                    a(j, i) = r.Offset(0, i).Value
                Next i
                j = j + 1
            End If
        Next r
    End With
    wb.Close False
    If a Is Nothing Then                                                //ใส่ if เพิ่ม
        MsgBox "ไม่มีข้อมุล" & ID, vbCritical
        End Sub
    Else
    ThisWorkbook.Worksheets("Sheet1").Range("A5").Resize(j, 51) = a
    End If
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Finished.", vbInformation
End Sub

[snasui]

3. รบกวนอาจารย์ อธิบาย code ตรงนี้ให้ทีครับ เป็น function ที่ผมไม่เคยใช้ เลยยังไม่ค่อยเข้าใจครับ จะได้นำไปประยุกต์ใช้ในโอกาสต่อไปครับ

Code: Select all

v = VBA.Join(Application.Transpose( _
                Application.Transpose(Application.Index(r.Resize(1, 51), 0))))

ขอบคุณครับ

แปลโดยรวมว่าให้ขยายตัวแปร r ไปทางด้านขวาไป 51 คอลัมน์ จากนั้นนำมาเชื่อมกันเป็นสายอักขระ

r.Resize(1, 51) แปลว่าให้ขยายตัวแปร r ไปทางขวา 51 คอลัมน์
Application.Index(r.Resize(1, 51), 0) ทำให้ช่วงข้อมูลเป็น Array โดยนำ Index ซึ่งเป็น Worksheet Function เข้ามาช่วย
Application.Transpose(...) เป็น Worksheet Function ที่นำมาช่วยสลับแกนของ Array แต่เนื่องจากใช้ช่วงเซลล์ใน Worksheet ซึ่งเป็น Array 2 มิติเป็นแหล่งข้อมูล จึงต้องทำการสลับแกน 2 รอบ (ใช้ Statement นี้ 2 ครั้ง) เพื่อให้เป็น Array 1 มิติที่สามารถนำมาเชื่อมกันด้วยฟังก์ชั่น Join ได้
VBA.Join(...) นำ Array มาเชื่อมกัน

[snasui]

เจอปัญหาใหม่ครับ เมื่อทดลองใส่ ข้อมูลที่ผิด หรือไม่มี contract no นั้น เข้าไป พบว่า code error

สังเกตว่าเราใช้ตัวแปร j เป็นตัวนับหากพบข้อมูล และหากไม่พบข้อมูลตัวแปร j จะมีค่าเป็น 0 ดังนั้น การจะตรวจสอบว่ามีข้อมูลหรือไม่สามารถตรวจสอบจากตัวแปร j ได้โดยตรง

หากใช้ If ตรวจสอบก็จะได้เป็นดังนี้ครับ

Code: Select all

'...
If j = 0 Then
    MsgBox "ไม่มีข้อมุล", vbCritical
    Exit Sub
Else
'... 

[lnongkungl]

ขอบคุณครับ อาจารย์ สำหรับความรู้ และคำแนะนำ ตอนนี้การทำงานของ code สมบูรณ์แล้วครับ แต่ได้รับโจทย์ใหม่มาเพิ่ม คือ แปลง code ชุดนี้ให้เป็น function โดยใช้ตัวแปรหาข้อมูล คือ ชื่อไฟล์ และ contract no. ก็คือ concept เดียวกัน

ชื่อFunction(ชื่อไฟล์,เลขcontract) ประมาณนี้ครับ


สามารถแปลง code ได้มั้ยครับ

ขอคำแนะนำด้วยครับ ขอบคุณครับ

[snasui]

สามารถแปลงได้แต่ต้องแปลงมาเองก่อน ติดตรงไหนค่อยถามกันต่อครับ

[lnongkungl]

ผมลองโยกมาเป็น function แล้วครับ concept คือ ยังอ้างไฟล์จาก cell B1 เพื่อเปิดไฟล์ที่ค้นหาอยู่ และคีย์เลข contract no หรือ อ้างจาก cell ใดๆ ใส่ใน function และผลลัพท์ที่ต้องการคือช่องข้อมูลใน colume a
คือ วันที่นำมาแสดงใน cell เดียวต่อกันครับ แต่ผลออกมาคือว่างเปล่า ไม่มี error บอกเลยว่า code ผิดตรงไหน หรือการทำงานของ code ติดตรงไหน ผมเลยไม่รู้ไปต่อยังไงครับ

code function อยู่ที่ module2 ครับ และผมลอง run ที่ A8 ผลคือ #VALUE!

[snasui]

ตัวอย่างการปรับ 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(999999, 0) As Variant
    Dim i As Long
    Dim xlApp As Application
    
    Application.Volatile
    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 & ".xlsx", 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
                a(j, 0) = r.Value
                j = j + 1
            End If
        Next r
    End With
    wb.Close False

    SearchContact_Func = a
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Function

Parameter f คือ Path ของไฟล์ ส่วน c คือข้อความที่ต้องการค้นหา

การเขียนฟังก์ชั่นจะเป็นลักษณะนี้คือ

=SearchContact_Func(B1,B2)

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

การเขียนฟังก์ชั่นไม่ว่าจะใน Module เดียวกันหรือ Module ใหม่ จำเป็นต้องให้ชื่อแตกต่างกันไป ไม่เช่นนั้นเมื่อเรียกใช้งานแล้วจะ Error เพราะชื่อซ้ำ หากเป็น Tools ชนิดอื่น ๆ เช่น Visual Stidio ถึงจะทำเช่นนั้นได้ครับ

[lnongkungl]

ขอบคุณที่ชี้แนะครับอาจารย์ เรียนตามตรงครับ ความรู้ในการเขียน vba ผมไม่มีเลย ก็ค้นหาจากใน forum ของอาจารย์บ้าง ใน google บ้าง แล้วเอามาลองเขียนดูครับ เชิงลึกผมเลยไม่ทราบเลย ได้แค่พื้นฐาน ติดตรงไหนก็ค้นหาใน google เอาว่าแก้ยังไง จนปัญญาจริงๆ จึงเข้ามาถามอาจารย์ครับ เขียน sub() ก็ยากสำหรับผมแล้ว แล้วมาเจอเรื่อง function() หนักหัวไปใหญ่ครับ

ขอถามต่อครับ เกี่ยวกับ code ในการเปิดไฟล์

Code: Select all

Set wb = Workbooks.Open(Filename:=.Range("B1").Value & ".xlsx", ReadOnly:=True)

ในส่วนนี้ถ้าเราไม่กำหนดนามสกุล .xlsx คือให้พิมพ์ชื่อไฟล์และนามสกุลติดกันใน B1 เลย มีวิธีปรับ code ยังไงครับ เพราะผมลองเอา & ".xlsx" ออก แล้วพิมพ์ชื่อ+นามสกุลของไฟล์ไปเลย มัน error ที่บรรทัดนี้ หรือมันมีข้อจำกัดใน code ชุดนี้ยังไงครับ

ความหมายคืออาจจะเอาไปปรับใช้กับงานอื่น ที่อาจจะไม่ใช่ .xlsx ครับ

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

[snasui]

ในส่วนนี้ถ้าเราไม่กำหนดนามสกุล .xlsx คือให้พิมพ์ชื่อไฟล์และนามสกุลติดกันใน B1 เลย มีวิธีปรับ code ยังไงครับ

คีย์ชื่อไฟล์เเข้าไปตรง ๆ แต่ต้องครอบด้วยเครื่องหมายฟันหนู ดังตัวอย่างด้านล่างครับ

Code: Select all

Set wb = Workbooks.Open(Filename:="D:\folder\abcdefghijklmnopqrstuvwxyz.xlsx", ReadOnly:=True)

ข้อความทุกชนิด จะต้องครอบด้วยเครื่องหมายฟันหนู ไม่ว่าจะอยู่ในสูตรหรือใน Code ส่วนตัวเลขและตัวแปรที่ตั้งขึ้นมาเองสามารถใช้ได้ตรง ๆ ไม่ต้องครอบด้วยเครื่องหมายฟันหนูแต่อย่างใด

ผมอ่านจาก Help และ Website ของ Microsoft โดยตรงเป็นหลักครับ

ตำรา VBA ลอง Search ของผู้เขียนที่ชื่อว่า John Walkenbach ซึ่งปัจจุบันไม่ได้เขียนแล้ว แต่ผู้เขียนปัจจุบันยังอ้างอิงมาใช้อยู่ครับ

[lnongkungl]

ไม่ได้หมายถึงใน code ครับ หมายถึงว่า ยังเอาค่าจาก B1 เหมือนเดิม แต่ใน code มี & ".xlsx" เลยเหมือนชนกันเลยเกิดเป็น error

สมมุติพิมพ์ใน cell B1 = C:\sf\gewrh\hqnhgntrn.xlsx แบบนี้ครับ จึงอยากรู่ว่าใน code สามารถปรับให้ยืดหยุ่นรับกับทุกนามสกุลของไฟล์ เช่นอาจจะเป็นไฟล์ของ excel 2007 นามสกุลเป็น .xls ประมาณนี้ครับ

เพราะผมลองใส่ชื่อไฟล์ที่ B1เป็น C:\sf\gewrh\hqnhgntrn.xlsx แล้วลบ & ".xlsx" ใน code ออก มัน error ครับ

Code: Select all

Set wb = Workbooks.Open(Filename:=.Range("B1").Value, ReadOnly:=True)

[snasui]

ในเซลล์ B1 ต้องเขียน Path ให้มีนามสกุลไฟล์เอาไว้ด้วย จึงจะลบ & ".xlsx" ใน Code ออกได้ครับ

ถ้า Path ใน B1 มีไฟล์อยู่จริงย่อมจะไม่ Error ครับ

[lnongkungl]

ได้แล้วครับ เป็นที่ผมใส่ชื่อไฟล์เต็ม แล้วก็ไม่ได้ลบ

Code: Select all

& ".xlsx"

ออก มันเลย error

ทีนี้เราจะดัก code ยังไงครับว่า ถ้าชื่อไฟล์ที่พิมพ์ในช่อง b1 เป็นชื่อไฟล์ที่ไม่มีอยู่ใน path นั้นจริง หรือ อาจจะพิมพ์ชื่อไฟล์ผิด จึงหาไฟล์ไม่เจอ แล้วให้ขึ้น msgbox ว่าชื่อไฟล์ผิด หรือไฟล์ไม่มี ประมาณนี้ครับ ผมคิดไม่ออกว่าจะใส่ if ยังไง

ผมพอรู้หลักว่า

Code: Select all

If........then
MsgBox "ไม่มีข้อมุล" & ID, vbCritical
else
Set wb = Workbooks.Open(Filename:=.Range("B1").Value, ReadOnly:=True)
End If

แต่หลัง if จะใส่เงื่อนไขยังไงครับ

[lnongkungl]

หาข้อมูลไปเรื่อยๆ จนไปเจอการใช้ on error go to พอเข้าใจว่าเป็นการดัก error ที่จะเกิดขึ้นแต่ให้ไปทำที่เรากำหนดแทนเช่น msgbox แต่ผมลองทำดู ทำไมมัน error ตั้งแต่เขียน code แล้วครับ


รบกวนอาจารย์ อธิบายทีครับ

[lnongkungl]

ได้แล้วครับ หาวิธีทำจนเจอ

Code: Select all

Sub openbook()
Dim wb As Workbook
On Error GoTo err1
        Set wb = Workbooks.Open(Filename:=.Range("B1").Value, ReadOnly:=True)
err1:
        MsgBox "ไม่พบไฟล์ที่ค้นหา", vbCritical
        Exit Sub

End Sub

[Bo_ry]

หาไฟล์ File ใช้ Dir ถ้าไม่มีจะข้อความว่าง

Code: Select all

    If Dir(fp & ".xlsx") = "" Then
        MsgBox "File not found": Exit Sub

Function ไม่ค่อยเหมาะกับการคืนหลายๆ ค่านอกจากจะใชักับ MS365 ที่มี Spill Array
ใช้ Sub ดีแล้ว

Code: Select all

Sub Search()
Application.ScreenUpdating = False
Dim s As String, fp As String, r As Range, a, n As Long, wb As Workbook, l As Long
fp = Range("B1").Value
s = LCase(Range("b2").Value)
    If Dir(fp & ".xlsx") = "" Then
        MsgBox "File not found": Exit Sub
    Else
        Set wb = Workbooks.Open(fp & ".xlsx", ReadOnly:=True)
        l = wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        ReDim a(l)
        For Each r In wb.Sheets(1).Range("a8:a" & l)
            a(n) = Join(Application.Transpose(Application.Transpose(r.Resize(, 51))), "^")
            n = n + 1
        Next
        wb.Close
        a = Filter(a, s)
        If UBound(a) = -1 Then
            MsgBox "No data": Exit Sub
        Else
            With [A5].Resize(UBound(a) + 1)
                .Value = Application.Transpose(a)
                .TextToColumns Destination:=Range("A5"), DataType:=xlDelimited, Other:=True, _
                OtherChar:="^", FieldInfo:=Evaluate("choose({1,2},row(1:51),1)")
            End With
        End If
    End If
Application.ScreenUpdating = True
End Sub

[snasui]

Function ไม่ค่อยเหมาะกับการคืนหลายๆ ค่านอกจากจะใชักับ MS365 ที่มี Spill Array
ใช้ Sub ดีแล้ว

เราสามารถใช้ Index เข้าไปครอบเพื่อให้แสดงค่าออกมาทีละลำดับได้ครับ

แต่การใช้ Function ทำงานแบบข้ามไฟล์จะไม่เหมาะเพราะถ้ามีการเปิดปิดไฟล์จะมีผลต่อการคำนวณครับ

[Bo_ry]

เอา Index ไปครอบแล้วดึงที่ละตัว มีข้อมูล 100 ตัว
ก็ต้องใส่ Function 100 cells ก็ต้อง Run Function 100 รอบ
ยิ่งข้อนี้ต้องไปเปิดไฟล์อื่น ต้องเปิด ปิดไฟล์ 100 รอบ

Sub Run รอบเดียวได้ครบ 100 ตัว
แต่ถ้าเป็น Spill Array Function Run รอบเดียวก็ได้ครบ 100 ตัว

ก็เลยคิดว่ามันไม่เหมาะ