在多列上循环过滤器复制粘贴

Question

我有一个大文件作为脏数据出现，需要清理。一些数据是混合的，所以需要一个高级过滤器只显示“狗”，然后只复制可见单元格（列范围），将它们粘贴到指定列（在标题下方的第一个可见空白单元格上）清除过滤器并重复在下一列。这些需要搜索“狗”的列每 7 列出现一次。即 A1、H1、O1 等。我有以下脚本，我一直在使用它来尝试获得我正在寻找的结果。

2 个问题： 1）当它为第 410 列执行过滤器时，它应该只复制可见单元格，但在粘贴之后，当整个表格未过滤时，它实际上包括隐藏单元格。 2) 如果此脚本执行预期的操作，由于此操作需要在 50 列上执行，因此多次使用 select 会非常慢。

感谢任何帮助！ 谢谢

Sub CopyPaste()

    ActiveSheet.Range("$A$1:$API$65536").AutoFilter Field:=403, Criteria1:= _
    "=*Dog*", Operator:=xlAnd
    Range("OM2:ABP65536").SpecialCells(xlCellTypeVisible).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut

    Dim Rng As Variant

    Range("ABQ1").Offset(1, 0).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Cells(1).Select
    ActiveSheet.Paste
    ActiveWorkbook.Worksheets("clean_report").AutoFilter.Sort.SortFields.Clear
    ActiveSheet.ShowAllData 
    ActiveSheet.Range("$A$1:$API$65536").AutoFilter Field:=410, Criteria1:= _
    "=*Dog*", Operator:=xlAnd
    Range("OT2:ABP65536").SpecialCells(xlCellTypeVisible).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("ABQ1").Offset(1, 0).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Cells(1).Select
    ActiveSheet.Paste
    ActiveWorkbook.Worksheets("clean_report").AutoFilter.Sort.SortFields.Clear
    ActiveSheet.ShowAllData

End Sub

Answer 1

我相信以下代码将帮助您实现所需的结果，它将从 A 开始每 7 列循环，直到您的最后一列包含数据，它将使用标准“Dog”过滤给定列，复制所有可见单元格并粘贴到另一个工作表中，在以下工作表结果的情况下：

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("clean_report")
'declare and set your worksheet, amend as required
Dim wsResult As Worksheet: Set wsResult = Sheets("result")
'declare and set your worksheet, amend as required
Dim LastRow As Long, LastCol As Long, i As Long, ResultRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
Lastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'get the last column with data on Row 1

For i = 1 To Lastcol Step 7 'go through columns A then H in 7 column intervals
    ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, Lastcol)).AutoFilter Field:=i, Criteria1:="*Dog*", Operator:=xlAnd
    'filter by "Dog"
    ws.Range(ws.Cells(2, 1), ws.Cells(LastRow, Lastcol)).SpecialCells(xlCellTypeVisible).Copy
    'copy all visible cells from A2 to LastRow on LastCol
    ResultRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1
    'find next free row on result sheet
    wsResult.Range("A" & ResultRow).PasteSpecial xlPasteAll
    'paste in free row
    ws.ShowAllData
    'remove filter for next iteration of loop
Next i
End Sub

更新：

根据您的评论，请在下面找到更新版本，这将从 A 列循环到 OI（以 7 列间隔）并过滤“Dog”一词并将可见单元格粘贴到 Column 上下一个可用的空行铅：

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("clean_report")
'declare and set your worksheet, amend as required
Dim wsResult As Worksheet: Set wsResult = Sheets("result")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A

For i = 1 To 399 Step 7 'go through columns A to OI in 7 column intervals
    ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 402)).AutoFilter Field:=i, Criteria1:="*Dog*", Operator:=xlAnd
    'filter by "Dog"
    ws.Range(ws.Cells(2, 1), ws.Cells(LastRow, 402)).SpecialCells(xlCellTypeVisible).Copy
    'copy all visible cells from A2 to LastRow on LastCol
    ResultRow = ws.Cells(ws.Rows.Count, "PB").End(xlUp).Row + 1
    'find next free row on result sheet
    ws.Range("PB" & ResultRow).PasteSpecial xlPasteAll
    'paste in free row
    ws.ShowAllData
    'remove filter for next iteration of loop
Next i
End Sub