Excel 将行数可变的已筛选数据复制到新工作表中

我有一个过滤的工作表（ActionRegister），我只想将过滤的（可见的）单元格复制到同一工作簿中的新工作表中，称为“复制”。实际数据从第4行开始（上面的行是标题），行数可变，但始终是a:Q列

我没有VBA的经验，我真的很难找到解决方案。我见过用于复制到新工作簿等的代码，但我的背景非常有限，我甚至无法根据自己的目的修改它

---

是否有人可以提供代码，只复制可见/已过滤的单元格，并忽略可变行数的标题？谢谢！！：）

试试下面的sub

Sub cpVisible()
Dim MyProdName As String
Dim FilteredRange As Range
Dim myArr As Variant

    Sheets("ActionRegister").Range("$A$4:$Q$50000").AutoFilter Field:=2, Criteria1:="IT"
    Set FilteredRange = Sheets("ActionRegister").Range("$A$4:$Q$50000").SpecialCells(xlCellTypeVisible)
    FilteredRange.Copy Sheets("Duplicate").Range("A1")

End Sub

---

如果要根据条件筛选数据，则需要更改标准

（标准1:=“IT”）

和列号

（字段：=2）

。

也许此代码补丁可以帮您完成：

Option Explicit

Public Sub Copy_Columns()


    Dim r As Range
    Dim r2 As Range
    Dim lLast_Row1 As Long
    Dim lLast_Row2 As Long
     'identify the columns and copy the data
    With Worksheets("Raw").ListObjects(1).DataBodyRange
        Set r = Application.Union(.Columns(1), .Columns(2), .Columns(7)).SpecialCells(xlCellTypeVisible)
    End With
    With Worksheets("Output")
        Set r2 = .Range("B8:D8").Resize(.Range("B6").CurrentRegion.Rows.Count)

        r2.Clear
        r.Copy r2.Cells(1, 1).Offset(-1)

         'extend the formulas
        lLast_Row1 = .Range("E" & Rows.Count).End(xlUp).Row
        lLast_Row2 = .Range("B" & Rows.Count).End(xlUp).Row

        If lLast_Row2 > lLast_Row1 Then
            .Range("E" & lLast_Row1).Resize((lLast_Row2 - lLast_Row1) + 1, 6).FillDown
        End If         
    End With     
End Sub

---

你已经检查过了吗？另外，当在Stackoverflow中询问时，发布你已经尝试过的内容是一个很好的做法。我很感激这个反馈，但我没有尝试过任何东西，因为我对VBA没有经验，也不理解语法。我也看了那个（在网上搜索了大约4个小时，寻找不同的解决方案），但我的最大范围是>22000，是可变的，每天更新，因此不适用于我的问题。我同意，如果我有一点知识，我应该能够修改它，但不幸的是我没有：（谢谢，这是可行的，但它不仅复制可见/过滤的单元格，而只是复制整个工作表。是否有方法包括

特殊单元格（xlCellTypeVisible）

这里？这是我唯一修改过的问题，但是复制和粘贴过滤行应该只传输可见数据，而不是隐藏行。这非常有效！！非常感谢。不确定这是否有什么不同，但我复制的电子表格本身是通过宏自动过滤的，所以这可能与此有关用它？不管怎样，谢谢：）

sub makeDuplicate()

    application.displayalerts = false
    on error resume next
    worksheets("Duplicate").delete
    on error goto 0
    application.displayalerts = true

    dim target as range

    with worksheets.add(after:=worksheets("ActionRegister"))
        .name = "Duplicate"
        set target = .cells(1)
    end with

    with worksheets("ActionRegister")

        intersect(.range("A:Q"), .usedrange.offset(3, 0), .usedrange).SpecialCells(xlCellTypeVisible).copy _
          destination:=target

    end with

end sub