Question

我有一张带有S5 Sheet的（过滤）工作簿。我有56张带有S1张的excel文件，每个文件夹中有300到40万条记录。如果过滤工作簿的S5表的C列与文件夹中的excel文件列表（全部）的AG列匹配，我想从多个文件和S5的列数据A中复制匹配数据（过滤标准文件＆＃34 ;）在新摘要表的同一行。我从朋友那里得到的以下宏在某种程度上起作用。我必须运行它56次，如文件1,2,3 ... 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

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

1 个答案: