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

问题描述

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

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

这使我能够复制所有行，但随后我又想不出如何使过滤器再次工作（因为我需要完全按照发现的方式离开工作表）而不会受到工作表保护的阻碍。 / p>

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

解决方法

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

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

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

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

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

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

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

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

autofilter excel excel