删除空白（空）列Excel VBA

Question

我谦虚地请求帮助修改此代码。我创建了一个访问数据库，它是大约 30 个版本的 excel 电子表格的信息存储库，用于检索工作簿的最新信息。在工作簿更新了帮助表中的信息并且用户输入了适当的字段后，有许多未使用的列和行需要删除。每个帮助表都使用公式动态提取数据；因此，单元格并不是真正的空。我发现这段代码非常适合删除空单元格，但我不知道如何修改它以删除存储未使用的公式的列。

Sub RemoveBlankRowsColumns()
    Dim rng As Range
    Dim rngDelete As Range
    Dim RowCount As Long, ColCount As Long
    Dim EmptyTest As Boolean, StopAtData As Boolean
    Dim RowDeleteCount As Long, ColDeleteCount As Long
    Dim x As Long
    Dim UserAnswer As Variant

'Analyze the UsedRange
    Set rng = ActiveSheet.UsedRange
    rng.Select

    RowCount = rng.Rows.Count
    ColCount = rng.Columns.Count
    DeleteCount = 0

'Determine which cells to delete
    UserAnswer = MsgBox("Do you want to delete only the empty rows & columns " & _
    "outside of your data?" & vbNewLine & vbNewLine & "Current Used Range is " & rng.Address, vbYesNoCancel)

    If UserAnswer = vbCancel Then
        Exit Sub
    ElseIf UserAnswer = vbYes Then
        StopAtData = True
    End If

'Optimize Code
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

'Loop Through Rows & Accumulate Rows to Delete
    For x = RowCount To 1 Step -1
'Is Row Not Empty?
        If Application.WorksheetFunction.CountBlank(rng.Rows(x)) <> 0 Then
            If StopAtData = True Then Exit For
        Else
            If rngDelete Is Nothing Then Set rngDelete = rng.Rows(x)
            Set rngDelete = Union(rngDelete, rng.Rows(x))
            RowDeleteCount = RowDeleteCount + 1
        End If
    Next x

'Delete Rows (if necessary)
    If Not rngDelete Is Nothing Then
        rngDelete.EntireRow.Delete Shift:=xlUp
        Set rngDelete = Nothing
    End If

'Loop Through Columns & Accumulate Columns to Delete
    For x = ColCount To 1 Step -1
'Is Column Not Empty?
        If Application.WorksheetFunction.CountBlank(rng.Columns(x)) <> 0 Then
            If StopAtData = True Then Exit For
        Else
            If rngDelete Is Nothing Then Set rngDelete = rng.Columns(x)
            Set rngDelete = Union(rngDelete, rng.Columns(x))
            ColDeleteCount = ColDeleteCount + 1
        End If
    Next x

'Delete Columns (if necessary)
    If Not rngDelete Is Nothing Then
        rngDelete.Select
        rngDelete.EntireColumn.Delete
    End If

'Refresh UsedRange (if necessary)
    If RowDeleteCount + ColDeleteCount > 0 Then
        ActiveSheet.UsedRange
    Else
        MsgBox "No blank rows or columns were found!", vbInformation, "No Blanks Found"
    End If

ExitMacro:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    rng.Cells(1, 1).Select
End Sub

电子表格的屏幕截图

在电子表格的屏幕截图中，单元格 A1-T221 处于活动状态并正在工作簿中使用；然而，

• 第 222:5000 行包含此工作簿中未使用的公式。
• T1:EP5000 列包含本工作簿中未使用的公式。

再次感谢您帮助找到解决此修改需求的解决方案。

Answer 1

因为工作表函数COUNTBLANK() 将计算空单元格以及包含返回NULL 的公式的单元格，我们可以使用：

Sub KolumnKleaner()
    Dim N As Long, wf As WorksheetFunction, M As Long
    Dim i As Long, j As Long

    N = Columns.Count
    M = Rows.Count
    Set wf = Application.WorksheetFunction

    For i = N To 1 Step -1
        If wf.CountBlank(Columns(i)) <> M Then Exit For
    Next i

    For j = i To 1 Step -1
        If wf.CountBlank(Columns(j)) = M Then
            Cells(1, j).EntireColumn.Delete
        End If
    Next j
End Sub

将删除所有“空”列。

可能有点慢。

编辑#1：

这个版本可能更快：

Sub KolumnKleaner2()
    Dim N As Long, wf As WorksheetFunction, M As Long
    Dim i As Long, j As Long

    N = Columns.Count
    M = Rows.Count
    Set wf = Application.WorksheetFunction
    Application.ScreenUpdating = False

    For i = N To 1 Step -1
        If wf.CountBlank(Columns(i)) <> M Then Exit For
    Next i

    For j = i To 1 Step -1
        If wf.CountBlank(Columns(j)) = M Then
            Cells(1, j).EntireColumn.Delete
        End If
    Next j

    Application.ScreenUpdating = True
End Sub