删除空白（空）列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

将删除所有＆＃34;空＆＃34;列。

可能会有点慢。

修改＃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