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