复制范围而不排除自动过滤的行

Question

我正在尝试从具有自动过滤器的受保护工作表中复制特定范围，该范围内的几行已被过滤掉。 使用以下代码时，仅复制范围内的可见行：

origWB.Sheets("some data").Range("D3:LB77").Copy
targetWS.Cells(3, 4).PasteSpecial xlValues

正如我所说，工作表受到保护（由于各种原因，我无法在宏中取消保护它），所以我不能使用通常可以解决问题的命令：

origWB.Sheets("some data").Range("D3:LB77").EntireRow.Hidden = False

我已经能够取消过滤器：

origWB.Sheets("some data").AutoFilterMode = False

这使我能够复制所有行，但是我不知道如何让过滤器再次工作（因为我需要完全按照我找到它的方式离开工作表）而不会被工作表保护阻止。

我希望有一个解决方案可以暂时删除过滤器并在复制后恢复它，或者一个解决方案可以让我复制所有范围，包括隐藏/过滤的行，而不会弄乱过滤器本身。

Answer 1

我不确定是否可以通过“复制”来复制不可见的单元格。据我所知这是不可能的。

但是，可以逐个单元格地读取每个单元格值/样式属性。

对于较小的范围应该可以正常工作，但是当我们有更多单元格时它真的很慢（它试图读取每个值而不是复制整个范围，这很耗时）。

Option Explicit

Sub code()
'a little performence boost
Application.ScreenUpdating = False

Dim source_cols As Integer
Dim source_rows As Integer
Dim source_range As Range
Set source_range = Sheets("SourceSheet").Range("a1:LB77")
Dim destination_range As Range
Set destination_range = Sheets("targetSheet").Range("a1")
source_cols = source_range.Columns.Count
source_rows = source_range.Rows.Count


Dim col As Integer
Dim row As Integer
For row = 1 To source_rows
    For col = 1 To source_cols
        'Copy value
        destination_range.Offset(row - 1, col - 1).Value = source_range.Cells(row, col).Value
        
        'Copy some extra styling if needed
        destination_range.Offset(row - 1, col - 1).Interior.Color = source_range.Cells(row, col).Interior.Color
        destination_range.Offset(row - 1, col - 1).Font.Color = source_range.Cells(row, col).Font.Color
        destination_range.Offset(row - 1, col - 1).Font.Bold = source_range.Cells(row, col).Font.Bold
    
    Next col
Next row

Application.ScreenUpdating = True
End Sub

但是，我建议复制文件（或至少是工作表）以删除过滤器、复制整个范围并删除您刚刚复制的文件/工作表。

Answer 2

以下代码添加一个新工作表并将整个范围复制到新电子表格中，然后您可以在其中复制并粘贴到您喜欢的位置

我已将副本定向到现有过滤数据的下方，但这可以重定向

Sub CopyFilteredData()
    Dim wsDst As Worksheet, tblDst As Range
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("some data")
    Dim tblSrc As Range: Set tblSrc = wsSrc.Range("D3:LB77")
    
    Set wsDst = wb.Worksheets.Add
    Set tblDst = wsDst.Range(tblSrc.Address)
    tblDst = "='" & wsSrc.Name & "'!" & tblSrc.Address
    tblDst.Copy
    tblSrc.Offset(tblSrc.Rows.Count + 1, 0).PasteSpecial xlPasteValues
    
    Application.DisplayAlerts = False
    wsDst.Delete
    Application.DisplayAlerts = True
    
End Sub