VBA【範囲内が空白の行および空白の列を削除する方法】

Question

範囲内が空白の行および空白の列を削除したいです。
どの会社にどの商品をいくつ送るかという表を作っているのですが、
完成後に送る数が0の会社や商品を削除して見た目をスッキリさせています。
この作業をマクロで行いたいです。

添付の画像でいうと、
企業5の行はすべて空欄なので行ごと削除し、
商品Dの列はすべて空欄なので列ごと削除したいです
それ以外の行、列には値が入っているので変更したくありません。
実際には商品も企業も長々と続いています。

このようになって欲しいです。
よろしくお願いいたします。

追記：大変申し訳ありません、伝え忘れていることがありました。
表の最終行には結合されたセルと運送会社が入っており、
表の最終列には総数を計上するための計算式が入っています。
このため、空白行・列を取得することができませんでした。

丸投げの質問という指摘があり、そうだなと思ったので試したことも記載していきます。
表題の通り特定範囲の空白行・列が削除したいと思い、空白行　削除などの単語で検索し、
空白のセルを含む行や列を削除する単純な方法や、空白行を取得するマクロを見つけたのですが、
行や列全体が空白というわけではないのがネックになってこちらで質問いたしました。

Answer 1

データのあるセル範囲を取得して(CurrentRegionを使うと簡単)
そのセル範囲を For Each で Rows と Columns をループ処理
データがあるかどうかは Count関数で件数を数えで0件ならデータ無しと判断
データ無しの行または列を削除
というロジックで組んでみました。

Public Sub DelBlankRowCol()

    Dim rng As Range
    Set rng = Range("A1").CurrentRegion
    Set rng = Intersect(rng, rng.Offset(1, 1))

    Dim i As Long
    For i = rng.Rows.Count To 1 Step -1
        If WorksheetFunction.Count(rng.Rows(i)) = 0 Then
           rng.Rows(i).EntireRow.Delete
        End If
    Next
    For i = rng.Columns.Count To 1 Step -1
        If WorksheetFunction.Count(rng.Columns(i)) = 0 Then
           rng.Columns(i).EntireColumn.Delete
        End If
    Next
End Sub

データが数値だけなの場合はこれでいいですが、文字もあるなら、CountA関数に変更してください。

追記

最終行、最終列にデータがある場合のコードは下記で。

Public Sub DelBlankRowCol()

    Dim rng As Range
    With Range("A1").CurrentRegion
        Set rng = .Offset(1, 1).Resize(.Rows.Count - 2, .Columns.Count - 2)
    End With

    Dim i As Long
    For i = rng.Rows.Count To 1 Step -1
        If WorksheetFunction.Count(rng.Rows(i)) = 0 Then
            rng.Rows(i).EntireRow.Delete
        End If
    Next
    For i = rng.Columns.Count To 1 Step -1
        If WorksheetFunction.Count(rng.Columns(i)) = 0 Then
            rng.Columns(i).EntireColumn.Delete
        End If
    Next
End Sub

Comments

[nikuya]

回答ありがとうございます。追記したのですが、実は最終行と最終列にはデータがありました。ただ、こちらのCurrentRegionを利用する方法であれば問題ないと思うので、試してみます。

[nikuya]

追記いただいたコードで目論見通り表を整理することができました。ありがとうございます。そのまま使うと商品や企業が消えてしまい、CountAを使うと結合されたセルがあることによって商品や企業の数が変わってしまうのでうまくいきませんでしたが、コードはそのままに表の消したくない行、列の枠外に数字を記入することで解決しました。

Answer 2

【Test1】
Booleanを使い空白が有ったらTrueにして、最後までTrueだったら行、列を削除する。
行と列で2回のループになります。

【Test2】
データーが無い　イコール　最終行、列の番号＝1になるので1になればその行、列を削除
こちらの方が簡単です。

Sub Test1()
    Dim i As Long, j As Long
    Dim Blank As Boolean
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        '最終列まで空白が無いかを確認する
        For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
            If Cells(i, j) = "" Then
                '空白であればTrueにして続ける
                Blank = True
            Else
                '空白でなかったらFalseにしてループを抜ける
                Blank = False
                Exit For
            End If
        Next j
        'その行が最後までTrueであれば行削除
        If Blank = True Then
            Rows(i).Delete
        End If
    Next i

    For j = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
        For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
            If Cells(i, j) = "" Then
                Blank = True
            Else
                Blank = False
                Exit For
            End If
        Next i
        If Blank = True Then
            Columns(j).Delete
        End If
    Next j
End Sub

Sub Test2()
    Dim i As Long
    
    '行の削除
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If Cells(i, Columns.Count).End(xlToLeft).Column = 1 Then
            Rows(i).Delete
        End If
    Next i
    
    '列の削除
    For i = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
        If Cells(Rows.Count, i).End(xlUp).Row = 1 Then
            Columns(i).Delete
        End If
    Next i

End Sub

Comments

[nikuya]

迅速に回答いただき、またシンプルなコードを追記していただきありがとうございます。後出しで大変申し訳ないのですが、最終行、列にもデータが存在していたためこのまま使うことはできませんでした。ただ、最終行、列を削除し最初に提示した条件通りの表でtest2を試したら望み通りのデータが得られました。

[Taka1108]

Test1で最終行、最終列の部分2か所ずつに-1を追加すればできると思います。
Cells(Rows.Count, 1).End(xlUp).Row -1
Cells(1, Columns.Count).End(xlToLeft).Column -1

[nikuya]

追加で問題なく動きました。ありがとうございます。また、データーが無い　イコール　最終行、列の番号＝1になるので1になればその行、列を削除という考え方はとても参考になりました。