VBAで条件に一致するセルの隣の値をまとめる方法

質問

VBAで条件に一致する複数セルの隣のセルの値を取得し、まとめる方法教えて下さい！

下記例の様に、Ａ列に商品コード、Ｂ列にサイズ値の入力されたデータが８万行ほどあり、別シートに商品コード毎にサイズ値をまとめたいです。

例：
処理前
Ａ列（商品コード）　　　　　　Ｂ列（サイズ値）
abc1000　　　　　　　　　　　Ｓ
abc1001　　　　　　　　　　　Ｓ
abc1001　　　　　　　　　　　Ｍ
abc1001　　　　　　　　　　　Ｌ
abc1002　　　　　　　　　　　ＸＳ
abc1002　　　　　　　　　　　Ｓ

処理後（別シート）
Ａ列（商品コード）　　　　　　Ｂ列（サイズ値）
abc1000　　　　　　　　　　　Ｓ
abc1001　　　　　　　　　　　Ｓ：Ｍ：Ｌ
abc1002　　　　　　　　　　　ＸＳ：Ｓ

ＣＯＵＮＴＩＦで連番を振ってＭＡＴＣＨとＩＮＤＥＸ関数で抽出し、まとめるという方法で実現は出来たのですが、処理にかなりの時間を要するのでＶＢＡならもっと高速にできるのではないかと思い質問させて頂きました。

よろしくお願い致します。

回答No.3

keithin · ベストアンサー

＞データが８万行ほどあり

ちんたらやってると、手でやるより遅くなります。

＃１行目タイトル行、２行目からデータとする

sub macro1()
　dim lastRow as long
’準備
　lastrow = cells(rows.count, "A").end(xlup).row
　range("A:B").sort key1:=range("A1"), order1:=xlascending, header:=xlyes
　range("C:C").insert shift:=xlshifttoright
　range("C2:C" & lastrow).formula = "=IF(A1=A2,C1&"":"","""")&B2"

’コード抽出
　range("E:F").insert shift:=xlshifttoright
　range("A:A").advancedfilter action:=xlfiltercopy, copytorange:=range("E1"), unique:=true

’結果転記
　lastrow = cells(rows.count, "E").end(xlup).row
　with range("F2:F" & lastrow)
　.formula = "=VLOOKUP(E2,A:C,3)"
　.value = .value
　end with
　range("C:C").delete shift:=xlshifttoleft
end sub

お礼

一瞬で求めていたデータが弾き出されました！

大変助かりました！

ありがとうございます。

回答No.2

MackyNo1

>処理にかなりの時間を要するのでＶＢＡならもっと高速にできるのではないかと思い質問させて頂きました。

使用する関数の組み合わせなどに影響しますが、一般にエクセルに用意されている関数はプログラムが洗練されているため、極めて処理速度が速いので、必ずしもVBAで処理速度を向上できるとは限りません。
ただし再計算に時間がかかる場合はシートの動きが重くなるので計算方法を手動などにする必要があります。

このようなケースではピボットテーブルの機能を利用するのがお勧めです。

データ範囲をホームタブの「テーブルとして書式設定」でテーブルにしておき（この操作でデータの追加に自動対応します）、挿入タブのピボットテーブルで行フィールドに商品コード、列フィールドとΣ値(データフィールド）にサイズをドラッグしてピボットテーブルを完成させ、テーブル上で右クリックし「ピボットテーブルオプション」の集計とフィルタタブで列と行の総計を表示するのチェックを外します（添付画像の左側のテーブル）。

テーブルの右側の適当なセルに（）添付画像ではK5セルに以下の式を入力し下方向にオートフィルコピーします。
=IF(B5,B$4&"　","")&IF(C5,C$4&"　","")&IF(D5,D$4&"　","")&IF(E5,E$4&"　","")&IF(F5,F$4&"　","")

これで、適宜不要な列(B列からJ列）を選択して右クリックから「非表示」にすればご希望の集計データになっています。

ちなみに、提示した数式はサイズ数の種類が最大5つある場合ですので、必要に応じて適宜関数をつなげてください。

また、区切り文字は全角スペースにしてありますが、コロンにしたい場合は以下のように数式を変更してください。

=SUBSTITUTE(TRIM(IF(B5,B$4&"　","")&IF(C5,C$4&"　","")&IF(D5,D$4&"　","")&IF(E5,E$4&"　","")&IF(F5,F$4&"　","")),"　","：")

お礼

ピボットテーブルを使うという発想は思い浮かびませんでした！

今後の参考とさせて頂きます。

ありがとうございました。

回答No.1

tom04

こんにちは！
一例です。
標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Sheet1のデータをSheet2に表示するようにしてみました）

Sub Sample1() 'この行から
Dim i As Long, c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Range("A:B").ClearContents
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter , Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS.Range("A1")
.ShowAllData
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If wS.Cells(c.Row, "B") = "" Then
wS.Cells(c.Row, "B") = .Cells(i, "B")
Else
wS.Cells(c.Row, "B") = wS.Cells(c.Row, "B") & "：" & .Cells(i, "B")
End If
Next i
End With
End Sub 'この行まで

こんな感じではどうでしょうか？m（_ _）m

お礼

早速のご回答ありがとうございます！

もちろんＰＣのスペックも関係あるとは思いますが、７万行弱のデータで動かしてみたら処理に１０分以上掛ってしまいました。

ＶＢＡも書き方一つで処理速度は大幅に違うようですね。

参考とさせて頂きます。

ありがとうございました。