『銀魂2 掟は破るためにこそある』がいよいよ公開!>>

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

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

   A     B      C    D
  品番    品名    数量  比率
商品A1aaa *********** 45   0%
商品A1bbb *********** 1,500   5%
商品A1ccc *********** 215  1%
商品A1ddd *********** 492  2%
商品A1eee *********** 8,974  30%
商品A1fff *********** 5,656  19%
商品A1ggg *********** 8,603  28%
商品A1hhh *********** 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行しかないかたまりや小計行の間に総計行がある上のような表に対応するには
どのようなコードを書けばよいのでしょうか。
アドバイスお願いします。

A 回答 (9件)

たびたびごめんなさい。



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

前回の
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
    • good
    • 0
この回答へのお礼

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

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


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

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

何度もごめんなさい。



ママチャリさんの回答を参考にさせていただき、
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
    • good
    • 1

おはようございます。

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
    • good
    • 1
この回答へのお礼

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

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

続けてお邪魔します。



>例えば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セルに 2 を入力 → E2セルを選択 → メニューの右側フィルのアイコン(Σのアイコンの下にある、下向き矢印)をクリック
→ 連続データの作成 → 「列」を選択 → 停止値の欄に 1000 を入力 → OK
これで1000行目まで連番が入りますので、D2セルのフィルハンドルでダブルクリック!
これで1000行まで数式が入ります。
最後にE列を削除して完了!m(_ _)m
    • good
    • 1

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
    • good
    • 1
この回答へのお礼

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

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

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

こんにちは!



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

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
    • good
    • 1
この回答へのお礼

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

myR.Offset(, 1) = myR / myTotal

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

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

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

No.1です。


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

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


合計行の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
    • good
    • 1
この回答へのお礼

回答ありがとうございます!思い通りの結果になりました!
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

こんな感じかな?


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
    • good
    • 1
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング