VBA: loop through sheets and dictionary-CodePudding

I have a dataset with 23 columns and a varying amount of rows. I need to autofilter the data based on a set amount of criteria including wildcards, then copypaste the filtered result into the corresponding sheets (i.e. data with filter criteria SH00* should go in sheet SH00 - the sheets have the same name as the criteria without wildcards). The data to filter is in column I. This is what I have so far:

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

This code filters based on the criteria wildcards but applies the filters all at once. It also copypastes the whole result into the first sheet only. What I can't figure out at all is how to loop through the filtering and copypaste process at the same time.

Any help would be greatly appreciated.

CodePudding user response：

Export Filtered Data to Worksheets

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.FilterMode Then sws.ShowAllData
    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