いつもお世話になります。
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行しかないかたまりや小計行の間に総計行がある上のような表に対応するには
どのようなコードを書けばよいのでしょうか。
アドバイスお願いします。
No.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
こんにちは!たびたびのアドバイスありがとうございます。
小計値0のところは空欄で美しく仕上がりました^^。
試したのはデータ量が1000行ほどのテスト環境なので、処理速度はさほど変わらなかったですが、
もっと大きなデータや他の要素が入ってくると効果が表れるのでしょうね。
初心者の私には、なぜ一旦D列を消去するのかと、あとmyArea(1)の後ろの(1)が何を表しているのかが
理解できていませんが(xOx)。勉強します。
色々な方法を教えていただき本当にありがとうございましたm(_ _)m
tom04さんとママチャリさんお二方にベストアンサーを差し上げたいのですが、
今回は4度もアドバイスくださったtom04さんをベストアンサーに選ばせていただきましたm(_ _)m
No.8
- 回答日時:
何度もごめんなさい。
ママチャリさんの回答を参考にさせていただき、
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.7
- 回答日時:
おはようございます。
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
No.6
- 回答日時:
続けてお邪魔します。
>例えば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
No.5
- 回答日時:
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」という式が入るように)入れることって可能でしょうか。
No.4
- 回答日時:
こんにちは!
おそらく前回当方が投稿したものだと思います。
ちょっとやり方を変えてみました。
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
No.2
- 回答日時:
こんなやり方は、いかがでしょう。
合計行の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
No.1
- 回答日時:
こんな感じかな?
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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
ExcelでASCを使って全角を半角...
-
作成した数式を値として表示し...
-
Excel関数について教えてくださ...
-
Excel関数について教えてくださ...
-
条件付き書式設定で罫線を引き...
-
エクセルのセル内に分数などの...
-
エクセルの質問です。 F列からL...
-
Microsoft 365Excelの見開きペ...
-
ワークシートに出現したこの画...
-
エクセルの文字が途中から消える
-
Excelの警告について
-
タイムスタンプとテキストから...
-
シートの情報を別のシートへま...
-
マクロの処理が遅くなった
-
エクセルの数式バーのフォント...
-
Excelでの文字色
-
エクセルデーターから必要な項...
-
Excelの数字の前に入っている空...
-
excel2003 マクロボタンが押せない
-
エクセルでファイルの最終更新...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excelの警告について
-
Excelで数値を時間数に変換する...
-
エクセルの数式バーのフォント...
-
エクセルで数字の組み合わせを...
-
エクセルを使用して、円周率を...
-
Excelで特定の文字列が含まれて...
-
Excel 対象のセルに入力が無い...
-
任意の値が存在する行に名前を...
-
エクセルでファイルの最終更新...
-
index関数の説明をお願いします。
-
条件付き書式でやりたいのですが
-
重複しない値を取り出したい
-
【ExcelVBA】UTF-8(BOM無)でC...
-
【マクロ】マクロが割当てされ...
-
エクセル IF計算式?でしょうか?
-
エクセルで曜日を入れたい
-
表中の指定した条件の文字列を...
-
【Excel】版が同じ事を示す番号...
-
EXCELの散布図で日付が1900年に...
-
Excelについて。Excelに縦1列に...
おすすめ情報