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

Screenshot of spreadsheet

在电子表格中的屏幕截图，单元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