复制范围，但不排除自动筛选行

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

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

我已经将副本定向到在现有过滤数据下面，但可以重定向

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

Answer 2

我不确定是否有可能通过“复制”复制不可见的细胞。据我所知这是不可能的。

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

它应该可以很好地完成较小范围的工作，但是当我们有更多的单元格时，它会非常慢(它试图读取每个值，而不是复制整个范围，这很费时)。

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

但是，我建议复制文件(或至少工作表)删除筛选器，复制整个范围和删除您刚才复制的文件/工作表。