用來自不同工作簿的工作表過濾文件夾中的所有（多個）工作簿

Question

我有一個帶有S5工作表的（過濾）工作簿。 我有56個S1工作表的excel文件，每個文件夾中有300至40萬條記錄。 如果篩選工作簿的S5工作表的C列與文件夾中excel文件列表（全部）的AG列匹配，我想從多個文件中復制匹配數據和S5的列數據A（篩選條件文件”）在新摘要表的同一行中，我從朋友那里獲得的下面的宏在某種程度上可以正常工作，我必須像文件1、2、3 ... 56一樣運行56次，但這需要花費多個小時並跳過記錄，是否有更好的方法可用，謝謝您的幫助。

Sub FilterData ()

    Set kFS = CreateObject("Scripting.FileSystemObject")
    Set kF = kFS.GetFile("C:\Users\Tech\Desktop\TEST\SrcFile.xlsx")
    Dim mainWB As Workbook
    Set mainWB = Workbooks.Open("C:\Users\tech\Desktop\TEST\SrcFile.xlsx")
    mainWB.Sheets("S5").Select
    Dim newLastRow As Long

    'File1
    Set desFS = CreateObject("Scripting.FileSystemObject")
    Set desF = kFS.GetFile("C:\Users\tech\Desktop\TEST\Report\File1.xlsx")
    Dim desWB As Workbook
    Set desWB = Workbooks.Open("C:\Users\tech\Desktop\TEST\Report\File1.xlsx")
    desWB.Sheets("S1").Select

    Dim rng1 As Range, rng2 As Range, rngName As Range, rngName1 As Range, i As Integer, j As Integer
    For i = 1 To mainWB.Sheets("S5").Range("A" & Rows.Count).End(xlUp).Row
        Set rng1 = mainWB.Sheets("S5").Range("C" & i)
        Set rngName1 = mainWB.Sheets("S5").Range("A" & i)
        For j = 1 To desWB.Sheets("S1").Range("A" & Rows.Count).End(xlUp).Row
            Set rng2 = desWB.Sheets("S1").Range("AG" & j)
            Set rngName = desWB.Sheets("S1").Rows(j)
            If rng1.Value = rng2.Value Then
                rngName.Copy Destination:=mainWB.Sheets("New").Range("A" & i)
                rngName1.Copy Destination:=mainWB.Sheets("New").Range("AH" & i)

            End If

            Set rng2 = Nothing
        Next j
        Set rng1 = Nothing
    Next i
    desWB.Close

    newLastRow = mainWB.Sheets("New").Range("A" & Rows.Count).End(xlUp).Row
End Sub

Answer 1

未經測試，假設您在工作表“ S5”列“ C”中沒有重復項，並且在您的56個文件中僅存在一次。

Sub test()
    Application.ScreenUpdating = False

    Dim mainWB As Workbook, Wb As Workbook
    Dim P1 As Range, c As Range, P2 As Range

    Set D1 = CreateObject("scripting.dictionary")
    Set mainWB = Workbooks.Open("C:\Users\tech\Desktop\TEST\SrcFile.xlsx") 'This is your file with sheet "S5" and "New"
    Folder = "C:\Users\tech\Desktop\TEST\Report\" 'This is the folder with all 56 workbooks with sheet "S1"
    File = Dir(Folder & "*.xlsx")

    Set P1 = mainWB.Sheets("S5").Range("C1:C" & mainWB.Sheets("S5").Range("C999999").End(xlUp).Row)

    For Each c In P1: D1(c.Value) = c.Row: Next c

    Do While File <> ""
        Set Wb = Workbooks.Open(Folder & File)
        Set P2 = Wb.Sheets("S1").Range("A1", Wb.Sheets("S1").UsedRange.SpecialCells(xlCellTypeLastCell))
        T1 = P2

        For i = 1 To UBound(T1)
            If D1.exists(T1(i, 33)) Then
                For j = 1 To 33
                    mainWB.Sheets("New").Cells(D1(T1(i, 33)), j) = T1(i, j)
                Next j
                mainWB.Sheets("New").Cells(D1(T1(i, 33)), 34) = mainWB.Sheets("S5").Cells(D1(T1(i, 33)), 1)
            End If
        Next i

        Wb.Saved = True
        Wb.Close
        File = Dir()
    Loop

    Application.ScreenUpdating = True
End Sub

---

Sub test()
    Application.ScreenUpdating = False

    Dim mainWB As Workbook, Wb As Workbook
    Dim P1 As Range, c As Range, P2 As Range, a As Integer
    Dim T2()

    Set D1 = CreateObject("scripting.dictionary")
    Set mainWB = Workbooks.Open("C:\Users\tech\Desktop\TEST\SrcFile.xlsx") 'This is your file with sheet "S5" and "New"
    Folder = "C:\Users\tech\Desktop\TEST\Report\" 'This is the folder with all 56 workbooks with sheet "S1"
    File = Dir(Folder & "*.xlsx")

    mainWB.Sheets("New").Cells.Clear

    Set P1 = mainWB.Sheets("S5").Range("C1:C" & mainWB.Sheets("S5").Range("C999999").End(xlUp).Row)
    a = 1

    For Each c In P1: D1(c.Value) = c.Offset(0, -2).Value: Next c

    Do While File <> ""
        Set Wb = Workbooks.Open(Folder & File)
        Set P2 = Wb.Sheets("S1").Range("A1", Wb.Sheets("S1").UsedRange.SpecialCells(xlCellTypeLastCell))
        T1 = P2

        For i = 1 To UBound(T1)
            If D1.exists(T1(i, 33)) Then
                ReDim Preserve T2(1 To 34, 1 To a)
                For j = 1 To 33
                    T2(j, a) = T1(i, j)
                Next j
                T2(34, a) = D1(T1(i, 33))
                a = a + 1
            End If
        Next i

        Wb.Saved = True
        Wb.Close
        File = Dir()
    Loop

    mainWB.Sheets("New").Range("A1").Resize(UBound(T2, 2), UBound(T2)) = Application.Transpose(T2)

    Application.ScreenUpdating = True
End Sub