代码之家 › 专栏 › 技术社区 › eli-k

复制范围而不排除自动筛选的行

autofilter vba excel

eli-k · 技术社区 · 4 年前

我正试图从受保护的工作表中复制特定范围,该工作表具有自动筛选功能,其中筛选出了该范围内的几行。使用以下代码时,仅复制该范围内的可见行:

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

这使我能够复制所有行,但我无法弄清楚如何让过滤器再次工作(因为我需要让工作表保持原样),而不会被工作表保护阻挡。

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

0 回复 | 直到 4 年前

eli-k 4 年前

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

我已将副本定向到现有筛选数据下方,但可以重定向

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

Salamander Krajza 4 年前

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

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

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

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

但是,我建议复制文件(或至少是工作表)以删除筛选器,复制整个区域并删除您刚才复制的文件/工作表。