VBA：遍历工作表和字典

Question

我有一个包含 23 列和不同行数的数据集。 我需要根据一定数量的标准（包括通配符）自动过滤数据，然后将过滤后的结果复制粘贴到相应的工作表中（即具有过滤标准 SH00* 的数据应该放在工作表 SH00 中——工作表与没有通配符的标准同名).要过滤的数据在第一列。这是我目前所拥有的：

Sub Filter_Data()
Sheets("Blokkeringen").Select
        
'Filter
Dim dic     As Object
Dim element As Variant
Dim criteria As Variant
Dim arrData As Variant
Dim arr    As Variant

Set dic = CreateObject("Scripting.Dictionary")
arr = Array("SH00*", "SH0A*", "SH0B*", "SH0D*", "SH0E*", "SH0F*", "SH0H*", "SHA*", "SHB*", "SF0*")
With ActiveSheet
.AutoFilterMode = False
arrData = .Range("I1:I" & .Cells(.Rows.Count, "I").End(xlUp).Row)
For Each criteria In arr
For Each element In arrData
If element Like criteria Then dic(element) = vbNullString
Next
Next
.Columns("I:I").AutoFilter Field:=1, Criteria1:=dic.keys, Operator:=xlFilterValues
End With

'Copypaste
Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("SH00").Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Cells(1, 1).Select
    
Sheets("Blokkeringen").AutoFilterMode = False
Application.CutCopyMode = False
Sheets("Blokkeringen").Select
Cells(1, 1).Select

End Sub

此代码基于条件 + 通配符进行过滤，但同时应用所有过滤器。它还仅将整个结果复制粘贴到第一张纸中。 我完全想不通的是如何同时循环过滤和复制粘贴过程。

任何帮助将不胜感激。

Answer 1

将过滤后的数据导出到工作表

Option Explicit

Sub RefreshData()
    
    Const sName As String = "Blokkeringen"
    Const sCol As String = "I"
    Const dNamesList As String _
        = "SH00,SH0A,SH0B,SH0D,SH0E,SH0F,SH0H,SHA,SHB,SF0"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Range
    Dim shrg As Range: Set shrg = srg.Rows(1) ' Header Row
    Dim scrg As Range: Set scrg = srg.Columns(sCol) ' Criteria Column
    
    Dim dNames() As String: dNames = Split(dNamesList, ",")
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet
    Dim dfCell As Range
    Dim dName As String
    Dim svrg As Range ' Visible Range
    Dim n As Long ' Worksheet Names/Criteria Counter
    
    For n = 0 To UBound(dNames)
        
        dName = dNames(n)
        On Error Resume Next ' to check if it exists
            Set dws = wb.Worksheets(dName)
        On Error GoTo 0
        If dws Is Nothing Then ' does not exist
            Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            dws.Name = dName
        Else ' exists
            dws.UsedRange.Clear
        End If
        Set dfCell = dws.Range("A1")
        
        scrg.AutoFilter 1, dNames(n) & "*" ' begins with
        Set svrg = srg.SpecialCells(xlCellTypeVisible)
        sws.ShowAllData
        
        shrg.Copy ' use only header row to copy column widths
        dfCell.PasteSpecial xlPasteColumnWidths
        svrg.Copy dfCell
        
        ' Due to copying the column widths, the first ROW is selected.
        dws.Select
        dfCell.Select ' select first cell
        
        Set dws = Nothing ' it is not known if the next one exists
    
    Next n
    
    sws.AutoFilterMode = False
    sws.Select
    sws.Range("A1").Select
    
    Application.ScreenUpdating = True

    MsgBox "Data refreshed.", vbInformation

End Sub