Excel 宏幫助過濾和復制多個工作簿中的數據到不同的工作表

Question

我需要一些幫助（可能是很多幫助）來編寫一個宏來執行以下操作 -

在主工作簿中，用戶將從 sheet1 的下拉菜單中選擇 Select 選項 -> A、B 或 C，然后單擊運行宏按鈕。 宏將執行以下操作 -

->select sheet100 in master workbook

-> select files to open (all available in single folder, arranged by name)

-> Loop starts

-> open target file (has to start from 1st file by name in the folder)

-> search target file first row for value "Dimension"

 -> If Option A was selected set auto filter on Dimension with filters "One" and "two"
 -> If Option B was selected set auto filter on Dimension with filters "three" and " and "four"
 -> If Option C was selected set auto filter on Dimension with filters "five" and " and "six"

-> copy all filtered data

-> paste special values starting from cell A6 of sheet100 (which was activated above before loop started) in master workbook

-> goes to next sheet of master file

-> If there is a second worksheet, go to that worksheet

->  use the same logic to filter and copy data to master workbook's next sheet
    
-> loops till the last worksheet in the last target workbook

我有零碎的代碼，例如將下拉列表中選擇的值轉換為字符串，激活 sheet100，打開文件夾中的文件並為所有選定的目標文件運行循環，但無法完成整個代碼。

對此的任何幫助將不勝感激。

Answer 1

復制過濾列表時使用SpecialCells(xlCellTypeVisible) 。 我已將帶有過濾范圍的 header 復制到目標表，然后刪除了 header。 這避免了處理空列表的復雜性。

更新- 刪除了自動工作表創建並添加了檢查是否有工作表可以放置數據。 復制所有數據（帶標題），而不僅僅是過濾列。

更新 2 - 使用 Sheet100 到 Sheet118 作為工作表代碼名稱。

更新 3 - 將過濾器應用於所有列，僅粘貼特殊值。 您可以采取一些措施來加快代碼速度， 請參見此處

Option Explicit

Sub Macro1()

    Const FIRST_SHEET = 100
    Const LAST_SHEET = 118
    Const TARGET_ROWNO = 1 '
    Const TARGET_COLNO = 7 ' G
    Const FILTER_COL = "Vertical"

    Dim wbData As Workbook, wbMaster As Workbook
    Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
    Dim sFolder As String, sFile As String, sOption As String
    Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
    Dim crit As Variant, n As Long
    Dim OFLastCol As Long, OFLastRow As Long

    Dim dict As Object, sCodeName As String
    Set dict = CreateObject("Scripting.Dictionary")

    sOption = Sheet52.Range("H8").Value 'capturing selected vertical

    Select Case UCase(sOption) 'setting the filter values
        Case "INSURANCE": crit = Array("INSURANCE")
        Case "BFS": crit = Array("BFS")
        Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
        Case "FSI GGM": crit = Array("INSURANCE", "BFS")
        Case Else
            MsgBox "No option selected", vbCritical
            Exit Sub
    End Select

    ' select folder
    Application.StatusBar = "Please be select folder to scan..."
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = sFolder
        .Show
        sFolder = .SelectedItems(1)
    End With
    sFile = Dir(sFolder & "\*.xls*")

    Set wbMaster = ThisWorkbook

    ' clear data sheets
    ' and map code names to index
    For Each ws In wbMaster.Sheets
        sCodeName = ws.CodeName 'Sheet100 to sheet118
        dict(sCodeName) = ws.Index ' codename to index

        ' clear old data
        n = Mid(sCodeName, 6)
        If n >= FIRST_SHEET And n <= LAST_SHEET Then

           Set rng = ws.UsedRange
           iLastCol = rng.Column + rng.Columns.Count - 1
           iLastRow = rng.Row + rng.Rows.Count - 1
           If iLastCol >= TARGET_COLNO Then
               Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
               rng.Cells.ClearContents
               'Debug.Print "Cleared", n, rng.Address
           End If

        End If
    Next

    ' scan files
    n = 100
    Do While Len(sFile) > 0
        Set wbData = Workbooks.Open(sFolder & "\" & sFile, ReadOnly:=True) ' updatelink, readonly

        ' open each sheet in turn
        For Each wsData In wbData.Sheets

            ' find the filter column in row 1
            Set rng = wsData.Rows(1).Find(FILTER_COL, LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then

                colno = rng.Column
                ' last row of filter column
                OFLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row

                If OFLastRow > 1 Then
                    ' range to apply filter to
                    OFLastCol = wsData.Cells(1, Columns.Count).End(xlToLeft).Column ' move left
                    
                    Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
                    rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
                    ' range to copy
                    Set rng = rng.SpecialCells(xlCellTypeVisible)

                     ' is there data to copy
                    If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then

                        ' check sheet available
                        sCodeName = "Sheet" & n
                        If dict.exists(sCodeName) Then
                            Set wsMaster = wbMaster.Sheets(dict(sCodeName))
                        Else
                            MsgBox sCodeName & " not found", vbCritical
                            Exit Sub
                        End If

                        ' copy / paste all columns of visible rows
                        rng.Copy
                        With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
                            .PasteSpecial Paste:=xlPasteValues
                        End With
                        Application.CutCopyMode = False
                        wsMaster.Activate
                        wsMaster.Range("A1").Select
                    Else
                        MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
                    End If
                Else
                   MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
                End If
            Else
                MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
            End If
            n = n + 1 ' next data sheet
        Next
        wbData.Close False
        sFile = Dir() ' next file in folder
    Loop

    MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub

Answer 2

@CDP1802：更新 2 -我在第一張工作表本身失敗時對過濾器所做的修改代碼。 我沒有選擇 1 列，而是選擇了整個范圍並使用 colno 變量進行過濾。

這完全有效，但需要花費大量時間（近 10 分鍾）來粘貼 8200 行數據和 90 列的第一張表（總共需要 1 小時）。 我還添加了Paste:=xlPasteValues參數以加倍確定，但這仍然需要很長時間。 對於具有較少數據量的工作表，它以更好的速度通過。 知道為什么會發生這種情況嗎？

另外，您可以更改代碼中的過濾器邏輯嗎？ 我會將其標記為已接受的答案。

Sub test()
    Const FIRST_SHEET = 100
    Const LAST_SHEET = 118
    Const TARGET_ROWNO = 1 '
    Const TARGET_COLNO = 7 ' G
    Const FILTER_COL = "Vertical"
    Dim OFLastCol As Long
    Dim OFLastRow As Long
    

    Dim wbData As Workbook, wbMaster As Workbook
    Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
    Dim sFolder As String, sFile As String, sOption As String
    Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
    Dim crit As Variant, n As Long

    Dim dict As Object, sCodeName As String
    Set dict = CreateObject("Scripting.Dictionary")

    sOption = Sheet52.Range("H8").Value 'capturing selected vertical

    Select Case UCase(sOption) 'setting the filter values
        Case "INSURANCE": crit = Array("INSURANCE")
        Case "BFS": crit = Array("BFS")
        Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
        Case "FSI GGM": crit = Array("INSURANCE", "BFS")
        Case Else
            MsgBox "No option selected", vbCritical
            Exit Sub
    End Select

    ' select folder
    Application.StatusBar = "Please be select folder to scan..."
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = sFolder
        .Show
        sFolder = .SelectedItems(1)
    End With
    sFile = Dir(sFolder & "\*.xls*")

    Set wbMaster = ThisWorkbook

    ' clear data sheets
    ' and map code names to index
    For Each ws In wbMaster.Sheets
        sCodeName = ws.CodeName 'Sheet100 to sheet118
        dict(sCodeName) = ws.Index ' codename to index
       
        ' clear old data
        n = Mid(sCodeName, 6)
        If n >= FIRST_SHEET And n <= LAST_SHEET Then
           
           Set rng = ws.UsedRange
           iLastCol = rng.Column + rng.Columns.Count - 1
           iLastRow = rng.Row + rng.Rows.Count - 1
           If iLastCol >= TARGET_COLNO Then
               Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
               rng.Cells.ClearContents
               
           End If
           
        End If
    Next
MsgBox ("data cleared")
    ' scan files
    n = 100
    Do While Len(sFile) > 0
        Set wbData = Workbooks.Open(sFolder & "\" & sFile, ReadOnly:=True) ' updatelink, readonly

        ' open each sheet in turn
        For Each wsData In wbData.Sheets

            ' find the filter column in row 1
            Set rng = wsData.Rows(1).Find(FILTER_COL, LookAt:=xlWhole)
            
            If Not rng Is Nothing Then

                colno = rng.Column
                iLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row

                If iLastRow > 1 Then
                    ' range to copy and apply filter to one column
                    Set rng = rng.Resize(iLastRow, 1)
                    'rng.AutoFilter Field:=1, Criteria1:=crit, Operator:=xlFilterValues
                    
                    OFLastCol = wsData.Range("A1").End(xlToRight).Column
                    OFLastRow = wsData.Cells(wsData.Rows.Count, OFLastCol).End(xlUp).Row
                    Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
                    rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
                    Set rng = rng.SpecialCells(xlCellTypeVisible)

                     ' is there data to copy
                    If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then
                       
                        ' check sheet available
                        sCodeName = "Sheet" & n
                        If dict.exists(sCodeName) Then
                            Set wsMaster = wbMaster.Sheets(dict(sCodeName))
                        Else
                            MsgBox sCodeName & " not found", vbCritical
                            Exit Sub
                        End If
                            
                        ' copy / paste all columns of visible rows
                        wsData.UsedRange.SpecialCells(xlCellTypeVisible).Copy
                        With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
                            .PasteSpecial Paste:=xlPasteValues
                        End With
                        'wsMaster.Range("G1").Select
                        'Selection.PasteSpecial Paste:=xlPasteValues, _
                        'Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Application.CutCopyMode = False
                        wsMaster.Activate
                        wsMaster.Range("A1").Select
                    Else
                        MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
                    End If
                Else
                   MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
                End If
            Else
                MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
            End If
            n = n + 1 ' next data sheet
        Next
        wbData.Close False
        sFile = Dir() ' next file in folder
    Loop

    MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub