如何解决复制范围,不排除自动过滤的行
我正在尝试从一个受保护的工作表中复制一个特定范围,该工作表具有一个自动过滤器,该过滤器过滤掉了该范围中的几行。 使用以下代码时,仅复制范围内的可见行:
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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。