我有一個包含 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
此代碼根據條件 通配符進行過濾，但同時應用所有過濾器。它還僅將整個結果復制粘貼到第一張紙中。我根本想不通的是如何同時回圈過濾和復制粘貼程序。
任何幫助將不勝感激。
uj5u.com熱心網友回復：
將過濾后的資料匯出到作業表
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/424455.html