使用来自不同工作簿的工作表过滤文件夹中的所有（多个）工作簿

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