Question

我对我创建的一些Excel VBA代码有一个非常奇怪的问题。

我不会详细说明（除非需要），但我有代码可以将数据从一张纸过滤到另一张。

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

我创建了这个小宏来执行delete-part：

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

现在这个宏工作得非常完美且超高速（我每次都要检查大约500列），但是当我在我的VBA代码中调用这个宏时（代码复制过滤后的数据），会出现问题。

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

我添加了Application.CutCopyMode = False行，因为我认为它可能在其内存中包含了复制的数据，但这没有用。

有关如何解决此问题的任何想法？谢谢！

Answer 1

虽然您需要循环使用工作表的已用范围中的列 - 但您不需要逐个删除它们。您可以构建一个范围 - 使用Union - 创建一个只有标题的非连续范围的列，然后一次性删除它们。使用此技术禁用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

如果您尝试通过传递工作表字符串来运行子例程，您可以尝试下面的Robin代码...

请记住，您应该像在示例工作簿中那样插入一个不在ThisWorkbook Module上的新模块，将此代码放在像Module1，Module2等标准模块上。

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

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

2 个答案: