不変する範囲の列削除

料金表のシートがあって 項目の見出しがあってその項目の数は変動して
IDも記載されますが、そのIDの数も変動しており 行も列も変動します。
7行目からIDや料金が始めるのは変動しません。
それぞれ、項目ごとに料金が記載されて まとめの項目を見て7行目から全て0円の項目があった場合
同じ項目の列を削除する。

という事を行いたいと思い、色々とネットで調べたり
考えた結果、合計金額の項目の下の列にSUM関数を入れて
その結果、0なら同じ項目の列を削除するという方法を思いついたのですが

SUM関数を入れるマクロは何とか出来上がったのですが
同じ項目なら列を削除するという構想だけは出来ても、コードにするのが出来ないので
ご教授願えないでしょうか？


以下、簡単な構成図と
SUM関数を挿入するマクロです

Sub 合計()

Dim A As String
Dim B As String
Dim C As String

Dim D As String
Dim E As String
Dim F As String

Dim G As String


A = Replace(Replace(Cells.Find("合計金額").Address, "$", ""), "5", "")
B = Replace(Replace(Cells.Find("合計金額").Address, "$", ""), "5", "7")
'合計金額のセルアドレスを取得

C = Replace(Range(B, Range(A & Rows.Count).End(xlUp)).Address, "$", "")
'SUM関数の長さを取得するためのコード

With Range(B, Range(A & Rows.Count).End(xlUp))
.Cells(.Cells.Count).Offset(1).Formula = "=sum(" & C & ")"
End With
'SUM関数を挿入

G = Range(B, Range(A & Rows.Count).End(xlUp)).Address

D = Replace(Replace(Cells.Find("合計金額").Offset(1).End(xlToRight).Address, "$", ""), "6", "")
E = Replace(Replace(Cells.Find("合計金額").Offset(1).End(xlToRight).Address, "$", ""), "6", "7")
’合計金額の項目の端のセルアドレスを取るコード



F = Range(E, Range(D & Rows.Count).End(xlUp)).Offset(1).Address



Range(G).AutoFill Destination:=Range(G, F)
`挿入したSUM関数をオートフィルで広げる


End Sub

　　　　　　　　　
　　項　　　I　　　● 分野別 ●　　　　　　　●対象外●　　　　　　　　●合計金額●
　　番　　　D　　　　AA　　　BB　　小合計　　AA　　BB　　小合計　AA　BB
　　1　　　000-1　　\100　\ 0　　　\100　　　　\0　　\0　　　\0　　\100 \0
　　2　　　000-2　　\200　\ 0　　　\200　　　　\0　　\0　　　\0　　\200 \0
　　3　　　000-3　　\100　\ 0　　　\100　　　　\0　　\0　　　\0　　\100 \0
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　☆0　　☆400　　　　　

マクロ実行
・最初に合計金額の項目の下にSUM関数を挿入する。(ここは完成しています。☆部分）

・次に、その合計金額を見て全て0なら、合計金額の項目も
分野別も対象外の同じ項目も列ごと削除する

(この削除するコードの構想としてFINDで項目の列を検索して0なら削除させる方法だけは
思いつきましたが思いつくだけで、コードとして記載は出来ていないのが現状です）


実行後
　　　　　　　　　
　　項　　　I　　　● 分野別 ●　　　　　●合計金額●
　　番　　　D　　　　AA　　　　小合計　　　AA　
　　1　　　000-1　　\100　　　　\100　　　\200
　　2　　　000-2　　\200　　　　\200　　　
　　3　　　000-3　　\100　　　　\100　　　\100

質問者からの補足コメント

• 申し訳ありません
  打ち間違いです。
  
  ×不変する
  
  〇変動する

  No.1の回答に寄せられた補足コメントです。 補足日時：2016/02/23 19:11

No.2 ベストアンサー 回答者： fujillin 回答日時： 2016/02/23 10:53

よく理解できてないかもですが・・・

結局のところ、処理としては『各列について、７行目以降の合計値が0ならその行を削除』ということでよさそうに思えますが？
条件が不明のところもあるけれど、適当にマクロ化してみると、こんな感じでしょうか？
（かなりテキトーですが・・・）

Sub test()
　Dim rw As Long, col As Long, maxCol As Long
　Dim rng As Range, val

　Const minRow = 6 '　←項目で使用している行（どこかに項目名が記されていると仮定）
　Const minCol = 4 '　←削除対象としない列(不明なので4と仮定）

' 項目列の最大値を取得（処理対象範囲を求める）
　maxCol = minCol
　For rw = 1 To minRow
　　col = Cells(rw, Columns.Count).End(xlToLeft).Column
　　If maxCol < col Then maxCol = col
　Next rw


' 各列について、合計（=sum関数値）が０なら削除
　For col = maxCol To minCol + 1 Step -1
　　rw = Cells(Rows.Count, col).End(xlUp).Row
　　val = 0
　　If rw > minRow Then
　　　Set rng = Range(Cells(minRow + 1, col), Cells(rw, col))
　　　val = Application.WorksheetFunction.Sum(rng)
　　End If
　　If val = 0 Then Columns(col).Delete
　Next col
End Sub

この回答へのお礼

質問から、ここまでのコードありがとうございます。
ﾍﾞｽﾄｱﾝｻｰに選ばさせて頂きます。

お礼日時：2016/02/23 19:13

No.3 回答者： fujillin 回答日時： 2016/02/23 15:02

ANo2です。

間違えた説明記述をしてしまいました。訂正です。

誤：『各列について、７行目以降の合計値が0ならその行を削除』
　　　　　　　↓　↓　↓
正：『各列について、７行目以降の合計値が0ならその列を削除』

No.1 回答者： mike_g 回答日時： 2016/02/23 09:37

タイトル中の「不変する」てな言葉、初めて見ましたが、どういう意味のつもりですか？