excel VBA：循环遍历图纸和字典

eyh26e7m 于 2023-02-05 发布在其他

关注(0)|答案(1)|浏览(199)

我有一个有23列和不同行数的数据集。我需要根据一组条件（包括通配符）自动筛选数据，然后将过滤后的结果复制粘贴到相应的工作表中（即，带有过滤标准SH00 * 的数据应放入表SH00中-表的名称与标准相同，但不带通配符）。要过滤的数据位于第I列。这是我目前掌握的情况：

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

这段代码基于条件+通配符进行过滤，但同时应用所有过滤器。它还将整个结果复制粘贴到第一个工作表中。我完全搞不懂的是如何同时循环过滤和复制粘贴过程。
任何帮助都将不胜感激。

excel

来源：https://stackoverflow.com/questions/71114986/vba-loop-through-sheets-and-dictionary

1条答案

按热度按时间

dl5txlt91#

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

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

赞(0）回复(0）举报 2023-02-05

我来回答

excel VBA：循环遍历图纸和字典

1条答案

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

相关问题

热门标签

最新问答