空白（空）の列を削除するExcel VBA

Question

このコードを変更するには、謙虚にお問い合わせください。私は、ワークブックの最新情報を取得するために使用するExcelスプレッドシートの約30バージョンの情報リポジトリであるアクセスデータベースを作成しました。ワークブックがヘルパーシートの情報を更新し、ユーザーが適切なフィールドを入力すると、削除する必要のある未使用の列と行が多数あります。各ヘルパーシートは、数式を使用してデータを動的にプルします。したがって、セルは真に空ではありません。私は空のセルを削除するために驚くほどうまく動作するこのコードを見つけましたが、使用されていない数式を格納する列を削除するように変更する方法を見つけることができません。スプレッドシートのスクリーンショットに

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 

は、すべての「空」の列を削除します。

少し遅くなることがあります。

EDIT＃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