通过屋顶的Excel内存，同时删除空列

我创build的Excel VBA代码有一个很奇怪的问题。

我不会进入细节（除非需要），但我有代码过滤和复制数据从一个表到另一个。

在这第二张纸上，它检查空列并删除它们。

我已经创build了这个小macros做删除部分：

Public Sub deleteemptyrows() Dim C As Integer Range("A1").Select Application.CutCopyMode = False C = ActiveSheet.Cells.SpecialCells(xlLastCell).Column Do Until C = 0 If WorksheetFunction.CountA(Columns(C)) = 1 Then Columns(C).Delete End If Debug.Print C C = C - 1 Loop End Sub 

现在，这个macros的工作完美和超快（对于我每次检查大约500列），但是当我在我的VBA代码（代码复制过滤的数据后）调用此macros时，会出现问题。

当它到达行Columns(C).Delete EXCEL.exe的内存在任务pipe理器中高达Columns(C).Delete ，并且它运行非常慢，逐列。

我已经添加了Application.CutCopyMode = False行，因为我认为它可能在内存中有复制的数据，但是这没有帮助。

任何想法如何解决这个问题？ 谢谢！

Answer 1

虽然您需要循环使用表格的已用范围中的列 – 您不需要一一删除它们。 您可以构build一个范围（使用Union ）来创build只有标题的非连续范围的列，然后将它们全部删除。 使用这种技术来禁用Application各种属性应该给你一个有效的方法：

 Option Explicit Sub DeleteColumnsEfficiently() Dim ws As Worksheet Dim rngEmptyColumns As Range Dim rngColumn As Range Dim wsf As WorksheetFunction Dim lngSetting As Long ' set a reference to worksheet Set ws = ThisWorkbook.Worksheets("Sheet1") ' set reference to WorksheetFunction Set wsf = Application.WorksheetFunction ' initialise range of empty columns Set rngEmptyColumns = Nothing ' set application settings to optimise ui change With Application .ScreenUpdating = False .EnableEvents = False lngSetting = .Calculation .Calculation = xlCalculationManual End With ' loop columns in usedrange For Each rngColumn In ws.UsedRange.Columns ' check if only header populated If wsf.CountA(rngColumn) = 1 Then ' if just header - then add to range of columns If rngEmptyColumns Is Nothing Then Set rngEmptyColumns = rngColumn.Offset Else Set rngEmptyColumns = Application.Union(rngEmptyColumns, rngColumn) End If End If Next rngColumn ' delete columns with only header rngEmptyColumns.Delete ' reset application settings With Application .ScreenUpdating = True .EnableEvents = True .Calculation = lngSetting End With End Sub 

Answer 2

如果您正在尝试通过传递表格string运行子例程，则可以尝试下面的Robin代码…

记住你应该把这个代码放在一个标准模块，如Module1，Module2等，插入一个新的模块不在ThisWorkbook模块上，就像你在示例工作簿中所做的那样。

 Option Explicit Sub DeleteColumnsEfficiently(ByVal strSheetName As String) Dim ws As Worksheet Dim rngEmptyColumns As Range Dim rngColumn As Range Dim wsf As WorksheetFunction Dim lngSetting As Long ' set a reference to worksheet Set ws = ThisWorkbook.Worksheets(strSheetName) ' set reference to WorksheetFunction Set wsf = Application.WorksheetFunction ' initialise range of empty columns Set rngEmptyColumns = Nothing ' set application settings to optimise ui change With Application .ScreenUpdating = False .EnableEvents = False lngSetting = .Calculation .Calculation = xlCalculationManual End With ' loop columns in usedrange For Each rngColumn In ws.UsedRange.Columns rngColumn.Select rngColumn.Offset.Select ' check if only header populated If wsf.CountA(rngColumn) = 1 Then ' if just header - then add to range of columns If rngEmptyColumns Is Nothing Then Set rngEmptyColumns = rngColumn Else Set rngEmptyColumns = Application.Union(rngEmptyColumns, rngColumn) End If End If Next rngColumn ' delete columns with only header If Not rngEmptyColumns Is Nothing Then rngEmptyColumns.Delete End If ' reset application settings With Application .ScreenUpdating = True .EnableEvents = True .Calculation = lngSetting End With End Sub Sub Test() DeleteColumnsEfficiently "Sheet1" End Sub