EXCEL VBA 空白行と空白行に挟まれた行のまとまりに対する処理

いつもお世話になります。

A列に品番、B列に品名(*****部分)、C列に数値が入っています。小計行と総計行のA列は空白です。
このような表で、D列にC列の数量の比率(%)を入力していくマクロを組みたいと思っています。
A列の空白行と空白行に挟まれたまとまりに対し、C列の数値の合計を100%とした比率を
D列に入力していきたいのです。A列の行は可変で最終行はその時によって変わります。
下のようなイメージなのですが、うまく間隔が取れず、見づらくなってしまいました。
すみません...

　　　A 　　　 B 　 　　　C 　　　D
　　品番　　　　品名 　　 数量　 比率
商品A１aaa *********** 45 　 0%
商品A１bbb *********** 1,500 　 5%
商品A１ccc *********** 215 　1%
商品A１ddd *********** 492 　2%
商品A１eee *********** 8,974 　30%
商品A１fff *********** 5,656 　19%
商品A１ggg *********** 8,603 　28%
商品A１hhh *********** 4,723 　16%
　　　　　商品A1 Total 　 30,208 　100%
商品A2aaa *********** 2 　0%
商品A2bbb *********** 100 　1%
商品A2ccc *********** 150 　1%
商品A2ddd *********** 1,500 　11%
商品A2eee *********** 4,800 　36%
商品A2fff *********** 6,600 　50%
　　　　　商品A2 Total 13,152 　100%
　　　　　 商品A Total 　　　56,137
商品B1aaa *********** 13,509 　100%
　　　　　 商品B1 Total 13,509 　100%
商品B2aaa *********** 14 　 1%
商品B2bbb *********** 1,073 　45%
商品B2ccc *********** 1,290 　54%
　　　　　 商品B2 Total　　2,377 　100%
商品B3aaa *********** 3,171 　100%
　　　　　 商品B3 Total 3,171 　100%
商品B4aaa *********** 251 　100%
　　　　　 商品B4 Total 251 　100%
商品B5aaa *********** 1,154 　35%
商品B5bbb *********** 2,136 　65%
　　　　　商品B5 Total 3,290 　100%
商品B6aaa *********** 2,388 　100%
　　　　　　商品B6 Total 2,388
　　　　　　 商品B Total 24,986


Sub Sample1()
Dim i As Long, k As Long
Dim lastRow As Long, myRng As Range
lastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("D:D").Style = "Percent"
For i = 2 To lastRow
Set myRng = Cells(i, "A").End(xlDown).Offset(1, 2)
For k = i To myRng.Row
Cells(k, "D") = Cells(k, "C") / myRng
Next k
i = myRng.Row
Next i
End Sub

上のコードで、行が複数あるかたまりが続いている間はうまくいくのですが、
1行しかないかたまりが来ると参照する行がずれて変な値になってしまいます。
また、総計行が入っているところでもずれます。
1行しかないかたまりや小計行の間に総計行がある上のような表に対応するには
どのようなコードを書けばよいのでしょうか。
アドバイスお願いします。

No.1 回答者： よろずやkinchan 回答日時： 2018/06/15 14:37

こんな感じかな？

Sub Sample2()
Dim i As Long
Dim lastRow As Long, myRng As Range
lastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("D:D").Style = "Percent"
For i = lastRow To 2 Step -1
If IsEmpty(Cells(i, "A").Value) And Not IsEmpty(Cells(i - 1, "A").Value) Then
Set myRng = Cells(i, "C")
End If
If Not IsEmpty(Cells(i, "A").Value) Or Not IsEmpty(Cells(i - 1, "A").Value) Then
Cells(i, "D").Value = Cells(i, "C").Value / myRng.Value
End If
Next i
End Sub

この回答へのお礼

一番に回答いただきありがとうございます！動かしてみたのですが、
「オーバーフローしました」というエラーがでました。せっかくなので構文を活かしてLongをVariantに変えてみたり、For Nextをネストして自分で少しいじってみたりもしたのですが、うまくいかず...でも勉強になりました！貴重なお時間ありがとうございますm(_ _)m

お礼日時：2018/06/16 14:27

No.2 回答者： ママチャリ 回答日時： 2018/06/16 09:53

こんなやり方は、いかがでしょう。

合計行の100%の入れ方が、ちょっと強引です。

Sub sample()
Dim r As Range, r1 As Range, r2 As Range
Range("D:D").Style = "Percent"
Set r = Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants, 23)
For Each r1 In r.Areas
Set r2 = r1(r1.Count).Offset(1, 2)
r1.Offset(, 3).FormulaR1C1 = "=RC[-1]/" & r2.Address(True, True, xlR1C1)
r2.Offset(, 1) = 1
Next r1
End Sub

この回答へのお礼

回答ありがとうございます！思い通りの結果になりました！
100%の入れ方は「なるほど」ですね笑。今のところ小計の集計と合計行の値が一致しないことは稀なのでほとんど問題ないです。欲を言えば、別の列にコピーすることを想定して列を相対参照にできればよりよいのですが、難しかったです...。めちゃくちゃ強引ですが、

r1.Offset(, 3).FormulaR1C1 = "=RC[-1]/" & r2.Address(True, False, xlR1C1)

として一旦相対参照の式にしてから

Columns("D:D").Replace What:="F", Replacement:="C"

で分母の参照セルをC列に変えることで、とりあえず得たい結果にはなりました汗。大変初心者なのでまだまだ勉強しないといけないです。

貴重なアドバイスどうもありがとうございました！
今後ともよろしくお願いしますm(_ _)m

お礼日時：2018/06/16 20:29

No.3 回答者： よろずやkinchan 回答日時： 2018/06/17 09:25

No.1です。

小計行／総計行の品番が完全な空白でないときにオーバーフローしました。
一応ご報告まで。

No.4 回答者： tom04 回答日時： 2018/06/17 10:42

こんにちは！

おそらく前回当方が投稿したものだと思います。
ちょっとやり方を変えてみました。

Sub Sample2()
　Dim lastRow As Long
　Dim c As Range, r As Range
　Dim myTotal As Range, myArea As Range, myR As Range
　　Range("D:D").Style = "Percent"
　　lastRow = Cells(Rows.Count, "B").End(xlUp).Row
　　　Set c = Range("A2")
　　　　Do
　　　　　If c.Offset(1) <> "" Then
　　　　　　Set r = c.End(xlDown)
　　　　　Else
　　　　　　Set r = c
　　　　　End If
　　　　　　If r.Offset(1) = "" Then
　　　　　　　Set myTotal = r.Offset(1, 2)
　　　　　　　Set myArea = Range(Cells(c.Row, "C"), Cells(r.Row + 1, "C"))
　　　　　　　　For Each myR In myArea
　　　　　　　　　myR.Offset(, 1) = myR / myTotal
　　　　　　　　Next myR
　　　　　　　Set c = r
　　　　　　End If
　　　　　　　If r.Row = c.Row Then
　　　　　　　　Set c = r.End(xlDown)
　　　　　　　End If
　　　　　　If c.Row > lastRow Then Exit Do
　　　　Loop
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

前回に続いてのご回答、ありがとうございます！前回は大変お世話になりました。お礼が遅くなりすみません。
上の構文、自分としては一番しっくりきました。そして処理速度が断然早かったです！ただ、全部が「0」のかたまりの

myR.Offset(, 1) = myR / myTotal

のところで「オーバーフローしました」というエラーが出てとまるので
「On Error Resume Next」を入れるとうまくいきました。

毎回助けていただき感謝ですm(_ _)m

お礼日時：2018/06/23 20:27

No.5 回答者： tom04 回答日時： 2018/06/23 22:28

No.4です。

＞全部が「0」のかたまりの・・・

質問文だけではまったく予期できないデータですね。

個人的には
「On Error Resume Next」を使ってしまうと
仮にエラーの場合どこがエラーなのか判らなくなるので、極力使わないようにしています。

前回の

For Each myR In myArea
　myR.Offset(, 1) = myR / myTotal
Next myR

の3行を

If myTotal <> 0 Then
For Each myR In myArea
myR.Offset(, 1) = myR / myTotal
Next myR
End If

に変更したらどうなりますか？m(_ _)m

この回答へのお礼

ホントですね汗。改めて読むと、質問文から全部0のかたまりがあることなて全く想定できないです。情報不足ですみません。

ご指示通り変えるとバッチリでした！すごいです..ありがとうございます。
ついでにすみません、できれば値でなく計算式にしたいのです。
分母が行のみ絶対参照になるよう（例えばD9に「=C2/C$9」という式が入るように）入れることって可能でしょうか。

お礼日時：2018/06/23 22:52

No.6 回答者： tom04 回答日時： 2018/06/23 23:53

続けてお邪魔します。

＞例えばD9に「=C2/C$9」という式が入るように・・・

D列は数式で処理する！というコトになりますね。
となるとわざわざVBAにせず数式を入れてみてはどうでしょうか？

D2セル（セルの表示形式は　％　にしておく）に
=IF(AND(A1="",A2=""),"",IFERROR(C2/INDEX(C2:C$1000,MIN(IF(A2:A$1000="",ROW(A2:A$1000)-ROW(A1)))),""))

配列数式なので、Ctrl＋Shift＋Enterで確定！（←必須★）し
フィルハンドルで下へコピー！

これでなんとかお望みの結果にならないでしょうか。

※　実際のデータ数がどの程度あるかこちらでは判りませんが、
配列数式はPCに負担をかけるので、とりあえず1000行まで対応できる数式にしています。
1000の部分が3000～5000程度ならあまり負担にならないと思います。

※　1000行目までフィル＆コピーは大変でしょうから、E列を作業列として使い
E2セルに　２　を入力　→　E2セルを選択　→　メニューの右側フィルのアイコン（Σのアイコンの下にある、下向き矢印）をクリック
→　連続データの作成　→　「列」を選択　→　停止値の欄に　1000　を入力　→　OK
これで1000行目まで連番が入りますので、D2セルのフィルハンドルでダブルクリック！
これで1000行まで数式が入ります。
最後にE列を削除して完了！m(_ _)m

No.7 回答者： ママチャリ 回答日時： 2018/06/24 08:51

おはようございます。

No.2です。
まだ続いているようなので・・・、こんな感じです。

Sub sample2()
Dim r As Range, r1 As Range
Range("D:D").Style = "Percent"
Set r = Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants, 23)
For Each r1 In r.Areas
Set r1 = Union(r1, r1(r1.Count).Offset(1))
r1.Offset(, 3).Formula = "=" _
& r1(1).Offset(, 2).Address(False, False) _
& "/" _
& r1(r1.Count).Offset(, 2).Address(True, False)
Next r1
End Sub

この回答へのお礼

こんにちは！2度目のご回答、ありがとうございます。
上の文でしたいことがバッチリできました！自分はFormulaR1C1を使って式を入れようとしたのですが、書き方が間違っていたのでしょう、構文のまま貼り付いてしまいました（汗）。Formulaでなるほど、こんな風にできるんですね。勉強になりましたm(_ _)m

お礼日時：2018/06/24 11:49

No.8 回答者： tom04 回答日時： 2018/06/24 11:22

何度もごめんなさい。

ママチャリさんの回答を参考にさせていただき、
VBAで数式をいれてみました。（ママチャリさん、ごめんなさい）

Sub Sample3()
　Dim lastRow As Long
　Dim c As Range, r As Range
　Dim myTotal As Range, myArea As Range, myR As Range
　　Range("D:D").Style = "Percent"
　　lastRow = Cells(Rows.Count, "B").End(xlUp).Row
　　　'//▼D列を一旦消去//
　　　If lastRow > 1 Then
　　　　Range(Cells(2, "D"), Cells(lastRow, "D")).ClearContents
　　　End If
　　Set c = Range("A2")
　　　Do
　　　　If c.Offset(1) <> "" Then
　　　　　Set r = c.End(xlDown)
　　　　Else
　　　　　Set r = c
　　　　End If
　　　　　If r.Offset(1) = "" Then
　　　　　　Set myTotal = r.Offset(1, 2)
　　　　　　Set myArea = Range(Cells(c.Row, "C"), Cells(r.Row + 1, "C"))
　　　　　　　'//▼D列にエラー処理を含めた数式を入れる//
　　　　　　　For Each myR In myArea
　　　　　　　　myR.Offset(, 1).Formula = "=IF(" & myTotal.Address(True, False) & "<>0," & _
　　　　　　　　　　　　　　　　　　　　　myR.Address(False, False) & "/" & myTotal.Address(True, False) & ","""")"
　　　　　　　Next myR
　　　　　　Set c = r
　　　　　End If
　　　　　　If r.Row = c.Row Then
　　　　　　　Set c = r.End(xlDown)
　　　　　　End If
　　　　　If c.Row > lastRow Then Exit Do
　　　Loop
End Sub

これで小計値が「0」の場合の対応もできると思います。m(_ _)m

No.9 ベストアンサー 回答者： tom04 回答日時： 2018/06/24 11:46

たびたびごめんなさい。

前回のコードを少し変更してください。
前回のままでも問題ないのですが、ループさせていますのでデータ量が極端に多い場合は少し時間を要すると思います。
ループさせない方法にしてみました。

前回の
Set myArea = Range(Cells(c.Row, "C"), Cells(r.Row + 1, "C"))
'//▼D列にエラー処理を含めた数式を入れる//
For Each myR In myArea
myR.Offset(, 1).Formula = "=IF(" & myTotal.Address(True, False) & "<>0," & _
　　　　　　　　　　　　　myR.Address(False, False) & "/" & myTotal.Address(True, False) & ","""")"
Next myR

を消去し

Set myArea = Range(Cells(c.Row, "D"), Cells(r.Row + 1, "D"))
'//▼D列にエラー処理を含めた数式を入れる//
myArea(1).Formula = "=IF(" & myTotal.Address(True, False) & "<>0," & _
　　　　　　　　　　　myArea(1).Offset(, -1).Address(False, False) & "/" & myTotal.Address(True, False) & ","""")"
myArea.Formula = myArea(1).Formula

にしてみてください。

※　結局　「myR」という変数は不要になってしまいました。

少しは時間短縮になるかもしれません。m(_ _)m

この回答へのお礼

こんにちは！たびたびのアドバイスありがとうございます。

小計値０のところは空欄で美しく仕上がりました^^。
試したのはデータ量が1000行ほどのテスト環境なので、処理速度はさほど変わらなかったですが、
もっと大きなデータや他の要素が入ってくると効果が表れるのでしょうね。
初心者の私には、なぜ一旦D列を消去するのかと、あとmyArea(1)の後ろの(1)が何を表しているのかが
理解できていませんが（xOx）。勉強します。
色々な方法を教えていただき本当にありがとうございましたm(_ _)m


tom04さんとママチャリさんお二方にベストアンサーを差し上げたいのですが、
今回は4度もアドバイスくださったtom04さんをベストアンサーに選ばせていただきましたm(_ _)m

お礼日時：2018/06/24 12:16