感謝@FaneDuru，下面的代碼幫助我將過濾后的資料復制到新作業表中，我需要調整的是使用單獨的標題而不是所有資料的主標題復制每組資料，并使用lso 剪切資料而不是復制
代碼：
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF Is Nothing Then
rngF.Copy wsComp.Range("A1")
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
我希望資料看起來像什么（按標題分隔資料）
[![在此處輸入影像描述][1]][1]
鏈接到 Faneduru 個人資料：https ://stackoverflow.com/users/2233308/faneduru
如果我無法剪切和粘貼資料，我使用下面的代碼將復制的資料過濾到新作業表并使用“或公式”將其洗掉并過濾為 True 并洗掉這些行，因為過濾器只需要 2 個條件。
Sub Delete()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ActiveSheet.Range("B1").Rows.End(xlDown).Row
Set rng = ws.Range("A1:AD" & lastRow)
ActiveSheet.Range("AD1").Value = "TRUE/FALSE"
ActiveSheet.Range("AD2").Formula = "=OR(D2=""108169651"",D2=""108169430"",D2=""108168704"",D2=""108169596"")"
ActiveSheet.Range("AD2:AD" & lastRow).Formula = ActiveSheet.Range("AD2").Formula
With rng
.AutoFilter Field:=30, Criteria1:="True"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
我在（ CopyFilteredCustomersByCompanyNames）子的末尾添加了上述代碼的呼叫子：
Option Explicit
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
'Array of Distributors which we need to add in new sheets
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
'Clear all Filters if any
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the unique Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
'ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
ws.AutoFilterMode = False
'MsgBox "Ready..."
Delete
End Sub
是正確的還是您有任何其他建議
uj5u.com熱心網友回復：
請將下一個解決方案復制到標準模塊（而不是現有代碼）：
Option Explicit
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Sub InsertHeaders(ws As Worksheet)
Dim rngSub As Range, lastR As Long, firstAddress As String, rngUnion As Range
Dim i As Long, dict As Object
'check if more than one unique Account exists:
lastR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastR
dict(ws.Cells(i, 4).Value) = vbNullString
Next i
If dict.Count < 2 Then Exit Sub 'for only one customer code, no need of other headers...
'sort the range:
ws.UsedRange.Sort key1:=ws.UsedRange.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
'place Subtotals based on Account (customer number):
ws.UsedRange.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(12), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'delete last two rows:
lastR = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
ws.Rows(lastR - 1 & ":" & lastR).Delete: 'Stop
'place all cells containing "SUBTOTAL'" in formula in a Union Range:
Set rngSub = ws.UsedRange.Columns(12).Find(What:="SUBTOTAL", After:=ws.UsedRange.Columns(12).Cells(1), LookIn:=xlFormulas, lookat:=xlPart)
If rngSub Is Nothing Then Exit Sub
firstAddress = rngSub.Address
addToRange rngUnion, rngSub
Do
Set rngSub = ws.UsedRange.FindNext(rngSub)
addToRange rngUnion, rngSub
Loop While rngSub.Address <> firstAddress
'copy the header row to the places of Subtotals rows:
With ws.Rows("1:1")
.VerticalAlignment = xlCenter
.Copy rngUnion.EntireRow 'copy the header in all Union range
End With
'remove Subtotals (needed only temporary):
ws.UsedRange.RemoveSubtotal
End Sub
Sub addToRange(rngU As Range, rng As Range) 'sub adding the new range to a Union one...
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
您現有的代碼只有一個修改：新的子呼叫：
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
代替
rngF.Copy wsComp.Range("A1")
請在測驗后發送一些反饋。
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/515445.html
標籤：擅长vba
上一篇：如果特定單元格(DataBodyRange)包含特定子字串，則VBA代碼洗掉Excel表(ListObject)中的行