将可见和过滤的内容复制并粘贴到新工作簿中

Question

我有一些代码可以隐藏列，然后复制并粘贴到新工作簿中，供最终用户远离主工作簿作为反馈工具使用。如果源工作表没有应用过滤器，代码绝对可以正常工作，但是一旦最终用户应用了过滤器，代码就会中断并出现错误消息，并且不会复制任何数据。

这是我正在使用的代码；

Sub Create_Export_Summary_View()
'
'Description: This Macro will had all columns showing in the Summary View code and
'produce a new, locked down, copy for the HRA/HRBP to share with their customers
'
Dim c As Range
Dim ws As Worksheet
Set ws = Worksheets("Master")

ws.Unprotect "Reward18"

'Select columns to hide

'Unhiding all colums
ws.Columns("A:GP").EntireColumn.Hidden = False

'Hiding columns
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

ws.Select
'Pasting values and formats

     ws.Activate

     ws.Cells.Select


    Selection.SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'Freezing cells
        
    ActiveSheet.Range("C2").Select
    ActiveWindow.FreezePanes = True
    
'Add Filter
    ActiveSheet.Range("A1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    
'Reduce zoom
    ActiveWindow.Zoom = 70

End Sub

有时我需要根据客户修改隐藏的列。应用过滤器后，代码运行并返回以下错误；

“没有足够的内存来完成此操作。请尝试使用较少的数据或关闭其他应用程序”

电子表格不是特别大 - 最多 200 行 - 无论其他任何内容打开，都会出现此消息。非常感谢任何帮助，我不是 VBA 最好的，这完全难住了我！

Answer 1

“没有足够的内存来完成此操作”，您看到的错误消息通常发生在 Excel 难以管理大量数据或存在资源限制时。当频繁复制和粘贴大数据区域时，尤其是使用过滤器时，可能会发生这种情况。您应该限制复制和粘贴的数据范围。如果可能的话，避免复制完整的列或行。相反，仅选择您需要的单元格或范围。您正在代码中逐个复制并粘贴数据、格式和列宽。这可能会占用大量内存。考虑将这些任务合并到单个复制/粘贴操作中：

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

无需选择单元格和电子表格，而是直接使用对象。这不仅使您的代码更加高效，而且还最大限度地减少了出现内存问题的可能性。每次复制和粘贴操作后清除剪贴板以节省内存。粘贴后，添加

Application.CutCopyMode = False

：

Selection.PasteSpecial ' Your paste operation here
Application.CutCopyMode = False ' Clear the clipboard

使用

UsedRange

而不是

ws.Cells.Select

仅处理包含数据的单元格。这有可能极大地限制数据范围。

Set rng = ws.UsedRange
rng.Copy

隐藏列的代码可能会更加高效。您可以通过创建列字母数组并循环遍历它们来隐藏列字母。这使您的代码更加简洁和可维护。

Dim columnsToHide As Variant
Dim col As Variant

columnsToHide = Array("A:C", "F:J", "M:N", "Q:S", "U:AC", "AE:AI", "AK", "AM", "AR:AZ", "BK:CL", "CQ:DX", "DZ:EF", "EH:EM", "EO:EV", "EY:FB", "FD:FO", "FR:FW", "FZ:GF", "GH:GP")

For Each col In columnsToHide
    ws.Columns(col).EntireColumn.Hidden = True
Next col

如果可能，请避免在代码中使用过滤器。过滤器会大大增加内存消耗。如果您需要在执行代码后应用过滤器，请考虑手动执行。