Excel VBA筛选后复制可见单元格报内存不足错误求助

问题根源 #

当工作表应用筛选后，ws.Cells.SpecialCells(xlCellTypeVisible)会返回大量不连续的单元格区域（包括筛选隐藏行对应的空单元格区域），直接复制这些区域会触发Excel内存错误——哪怕实际有效数据只有200行。另外，原代码直接全选整个工作表（ws.Cells.Select），范围覆盖了从A1到GP1048576的所有单元格，这进一步放大了内存占用问题。

修复方案 #

• 缩小复制范围：只复制实际有数据的单元格区域，而非整个工作表
• 处理筛选状态：复制前先取消筛选，避免不连续区域的复制问题
• 摒弃Select/Activate操作：这类操作不仅低效，还容易引发逻辑错误

修改后的代码 #

Sub Create_Export_Summary_View()
'
'Description: This Macro will hide specified columns in the Summary View and
'produce a new, locked down, copy for the HRA/HRBP to share with their customers
'
Dim ws As Worksheet
Dim sourceRange As Range
Dim newWB As Workbook
Dim newWS As Worksheet

Set ws = Worksheets("Master")
ws.Unprotect "Reward18"

' 先取消所有筛选，避免后续复制不连续区域
If ws.AutoFilterMode Then
    ws.AutoFilterMode = False
End If

' 取消所有列隐藏
ws.Columns("A:GP").EntireColumn.Hidden = False

' 隐藏指定列
ws.Columns("A:C").EntireColumn.Hidden = True
ws.Columns("F:J").EntireColumn.Hidden = True
ws.Columns("M:N").EntireColumn.Hidden = True
ws.Columns("Q:S").EntireColumn.Hidden = True
ws.Columns("U:AC").EntireColumn.Hidden = True
ws.Columns("AE:AI").EntireColumn.Hidden = True
ws.Columns("AK").EntireColumn.Hidden = True
ws.Columns("AM").EntireColumn.Hidden = True
ws.Columns("AR:AZ").EntireColumn.Hidden = True
ws.Columns("BK:CL").EntireColumn.Hidden = True
ws.Columns("CQ:DX").EntireColumn.Hidden = True
ws.Columns("DZ:EF").EntireColumn.Hidden = True
ws.Columns("EH:EM").EntireColumn.Hidden = True
ws.Columns("EO:EV").EntireColumn.Hidden = True
ws.Columns("EY:FB").EntireColumn.Hidden = True
ws.Columns("FD:FO").EntireColumn.Hidden = True
ws.Columns("FR:FW").EntireColumn.Hidden = True
ws.Columns("FZ:GF").EntireColumn.Hidden = True
ws.Columns("GH:GP").EntireColumn.Hidden = True

' 获取实际有数据的可见区域，仅覆盖已使用单元格
Set sourceRange = ws.UsedRange.SpecialCells(xlCellTypeVisible)

' 创建新工作簿并粘贴内容
Set newWB = Workbooks.Add
Set newWS = newWB.ActiveSheet

sourceRange.Copy
newWS.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
newWS.Range("A1").PasteSpecial Paste:=xlPasteValues
newWS.Range("A1").PasteSpecial Paste:=xlPasteFormats

' 冻结窗格
newWS.Range("C2").Select
newWB.ActiveWindow.FreezePanes = True

' 添加筛选
newWS.Range("A1").AutoFilter

' 调整缩放比例
newWB.ActiveWindow.Zoom = 70

' 清理剪贴板，释放内存
Application.CutCopyMode = False

' 重新保护原工作表
ws.Protect "Reward18"
End Sub

关键改进点 #

1. 复制前取消筛选：确保复制的是连续的可见数据区域，避免不连续区域导致的内存异常
2. 使用UsedRange：仅复制实际有数据的部分，大幅减少复制的数据量
3. 直接操作对象：替代低效的Select/Activate操作，提升代码稳定性和运行速度
4. 补充工作表保护：原代码遗漏了保护原工作表的步骤，修改后补充完整

内容的提问来源于stack exchange，提问作者SeanG80