エクセルのマクロ【複数検索＆検索結果の合計】

質問

以下のように
【sheet1】にA列B列からなるデータにおいて
A列の内容が同じものどうしのB列の値を合計し
その結果の大きい順に並べて
【sheet2】に出力するマクロを
作りたいのですが、どうしたらよいかわかりません。
どなたかお分かりになる方いらっしゃいましたら
教えて頂きたくお願い致します。

【sheet1】　　
A列　　　　B列
aaa 5
bbb 4
aaa 3
aaa 2
ccc 89
bbb 100

【sheet2】
A列
bbb 104
ccc 89
aaa 10

回答No.1

KenKen_SP · ベストアンサー

ピボットでできるけど。。。

VBA なら Dictionary を利用するとか？ 以下は適当に書いたコード
なので参考までに。

Sub SampleProc()

　　Dim dic　　As Object ' Dictionary ' ※ Microsoft Scripting Runtime
　　Dim r　　　As Range
　　Dim sKey　 As String
　　Dim i　　　As Long
　　Dim n　　　As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　' // 集計
　　For i = 1 To 50 ' 1-50 行まで
　　　　sKey = Trim$(Cells(i, "A"))
　　　　Set r = Cells(i, "B")
　　　　If sKey <> "" And IsNumeric(r.Value) Then
　　　　　　If Not dic.Exists(sKey) Then
　　　　　　　　' // 新しい項目ならキーを追加
　　　　　　　　dic.Add Key:=sKey, Item:=r.Value
　　　　　　Else
　　　　　　　　' // 既出項目ならキーの値と合計する
　　　　　　　　' // 少数がある場合は丸め誤差に注意
　　　　　　　　dic(sKey) = CDbl(dic(sKey)) + r.Value
　　　　　　End If
　　　　End If
　　Next i

　　' // 結果出力
　　n = dic.Count
　　If n > 0 Then
　　　　' // セルへ記入
　　　　Range("D1").Resize(n).Value = Application.Transpose(dic.Keys)
　　　　Range("E1").Resize(n).Value = Application.Transpose(dic.Items)
　　　　' // 並べ替え
　　　　Range("D1:E1").Resize(n).Sort Key1:=Range("E1"), _
　　　　　　　　　　　　　　　　　　　Order1:=xlDescending
　　Else
　　　　MsgBox "集計できません", vbInformation
　　End If

　　Set r = Nothing
　　Set dic = Nothing

End Sub

お礼

KenKen_SPさん

有難うございました！
できました！

回答No.4

pauNed

（#2コメントへのレスです）
>どうしたらよいのでしょう。。。
えーと...
そのコードのセルアドレスをよく確認してください。
ご自分の環境にあわせて変更する際には、内容を理解して修正しましょう。

>Key1:=.Range("I1")
と、わざわざI列に修正しているという事は、
Consolidateの書き出し位置がH列I列という事ですね？
であれば、Sortの対象範囲もそれにあわせて修正しなければいけませんよ？

.Range("H1", .Range("H1").End(xlDown).Offset(0, 1)).Sort _
　　　　Key1:=.Range("I1"), _
　　　　Order1:=xlDescending, _
　　　　Header:=xlNo, _
　　　　OrderCustom:=1, _
　　　　Orientation:=xlTopToBottom

[並び替え]の動作を[マクロの記録]を録ってみると参考になりますよ。

お礼

pauNedさん

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

回答No.3

imogasi

データが変わった都度に瞬間的に処理しなければならない場合でなければ（、バッチ処理で良いなら）
判りやすいのは、下記と思います。古典的小計算出アルゴリズムです。
（１）A列でソートします。（もちろんA,B列を範囲指定して）
コードはマクロの記録をとれば、４行ぐらいだったと思う。
データ範囲の最下行の捉え方は
d=Range("A65536").End(xlUp).Row
ソート範囲は
Sub test01()
d = Range("A65536").End(xlUp).Row
MsgBox d
Range("A2:B" & d).Select
End Sub
その後
Selection.Sort・・
ーー
ソート後のデータについて
第１行のA列の値をーー＞前行データとして記憶
（２）データの最上行行から、順次、A列データについて、前の行のデータと変わったか、IF文でで聞く
（A)変わらない行は、合計（小計）にB列データを加える。
（B)変わったら、（A)の合計（小計）とA列直前行データをシート２のA,B列にそれぞれ書きだす。
合計（小計）を０に（ご破算）する。
今のB列現在行データを加える。
現在行のA列の値をーー＞前行データとして記憶
次行の処理へ
（C）最終行になったら、合計（小計）と最後のA列データをシート２に書き出す。
さあVBAコードが組めるかな。

お礼

imogasiさん
ありがとうございました！
できました。

回答No.2

pauNed

こんにちは。
[データ]-[統合]機能を使う手もありますね。

Dim r As Range

With Sheets("sheet1")
　　Set r = .Range("B1", .Range("A1").End(xlDown))
End With
With Sheets("sheet2")
　　.Range("A1").Consolidate _
　　　　　　Sources:=r.Address(ReferenceStyle:=xlR1C1, External:=True), _
　　　　　　Function:=xlSum, _
　　　　　　LeftColumn:=True
　　.Range("B1", .Range("A1").End(xlDown)).Sort _
　　　　　　Key1:=.Range("B1"), _
　　　　　　Order1:=xlDescending, _
　　　　　　Header:=xlNo, _
　　　　　　OrderCustom:=1, _
　　　　　　Orientation:=xlTopToBottom
End With
Set r = Nothing

お礼

pauNedさん

Sheet2に合計がきちんと出力されました！
有難うございます。
が、実行すると、
*****************************************************
.Range("B1", .Range("B1").End(xlDown)).Sort _
Key1:=.Range("I1"), _
Order1:=xlDescending, _
Header:=xlNo, _
OrderCustom:=1, _
Orientation:=xlTopToBottom
*****************************************************
の部分が黄色くなり
『実行時エラー'1004'』
並べ替えの参照が正しくありません。
並べ替えるデータ内にあることこ、
[最優先されるキー]ボックスが空白でないことを確認してください。
というエラーメッセージがでます。
度々すみません。
どうしたらよいのでしょう。。。