Excel表を集計するプログラム

質問

A列に複数の項目（重複もあり）があります。B列に数字が入っています。
A列の項目で重複しているものはMergeします。
それと同時にB列に入っていた数字を合計したいと思っています。

［具体例］
処理前　　→　　処理後
AAA　1　　　　　AAA　7
BBB　3　　　　　BBB　7
CCC　4　　　　　CCC　4
BBB　4　　　　　DDD　2
DDD　2
AAA　5
AAA　1

こんな感じの処理をVBAでしたいと思っています。
教えてください。
よろしくお願いいたします。

回答No.1

redfox63 · ベストアンサー

Dictionaryオブジェクトを使ってコレクションしながら集計すれば良いでしょう

参照設定で『Microsoft Scripting runtime』にチェックをつけておいて

Sub Macro1
　　dim dic as new Dictionaly
　　dim r0 as Range, r1 as Range
　　dim n as integer, sKey as variant

　　set r0 = range("A1", range("A65536").End(xlup))
　　for each r1 in r0
　　　　if dic.Exists( r1.value) = false then
　　　　　　dic.add r1.value, r1.offset(,1).value
　　　　els
　　　　　　n = dic(r1.value)
　　　　　　n = n + r1.offset8,1).value
　　　　　　dic.Remove r1.value
　　　　　　dic.add r1.value, n
　　　　end if
　　next

　　set r0 = Range("D1")
　　sKey = dic.Keys
　　for n = 0 to dic.Count-1
　　　　r0.value = sKey(n)
　　　　r0.offset(,1).value = Dic(sKey(n))
　　　　Set r0 = r0.Offset(1)
　　next
End Sub

といった具合です

お礼

回答ありがとうございます。
大変参考になりました。

Dictionaryオブジェクトは使えそうですね。

回答No.4

pkh4989

こんにちは。
配列を利用した方法です。ご参考に！

Type SumRec
　　CODE　　　　As String
　　CNT　　　　 As Long
End Type
Dim SUM()　　　 As SumRec
Dim SumCnt　　　As Long

Sub 集計()
　　Dim wIx　　 As Long
　　Dim wR　　　As Long
　　Dim FindFlg As Boolean
　　'
　　Application.ScreenUpdating = False
　　Erase SUM
　　SumCnt = 0
　　With ActiveSheet
　　　　wR = .Range("A" & Rows.Count).End(xlUp).Row
　　　　'集計
　　　　For wIx = 1 To wR
　　　　　　FindFlg = False
　　　　　　For wIy = 1 To SumCnt
　　　　　　　　If SUM(wIy).CODE = .Cells(wIx, "A") Then
　　　　　　　　　　FindFlg = True
　　　　　　　　　　SUM(wIy).CNT = SUM(wIy).CNT + .Cells(wIx, "B")
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　　　If FindFlg = False Then
　　　　　　　　If .Cells(wIx, 1) <> "" Then
　　　　　　　　　　SumCnt = SumCnt + 1
　　　　　　　　　　ReDim Preserve SUM(SumCnt)
　　　　　　　　　　SUM(wIy).CODE = .Cells(wIx, 1)
　　　　　　　　　　SUM(wIy).CNT = .Cells(wIx, 2)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　'展開
　　　　.Columns("D:E").ClearContents
　　　　For wIx = 1 To SumCnt
　　　　　　.Cells(wIx, "D") = SUM(wIx).CODE
　　　　　　.Cells(wIx, "E") = SUM(wIx).CNT
　　　　Next
　　End With
　　Application.ScreenUpdating = True
End Sub

お礼

回答ありがとうございます。
参考にします。

回答No.3

imogasi

質問者がどれだけの経験者かわからないが、エクセルの経験が余りないのに難しい課題をやろうとしているように思う。
＞Merge
CellMerge（セル結合）のことか、プログラムでいうMergeのことか。難しい英語を使わず正確に。
ここではセル結合の意味として、セルの結合という発想でなく、
A.同じ商品（仮に質問のAAAを商品名としての例）は集計すると考える
B。別シートに結果を出す
という風に考えるのが良いと思う。
ーーー
既出のピボットテーブルを、操作でやるのが良いのではないですか。
VBAを使わなくても。勉強するなら別ですが。
ーー
既出のVBScriptのDictionaryなど概念習得が難しいと思う。
ーー
私なら、VBAでなら、元のシートを商品でソートし、商品の切れ目までを足し算して、書き出してやります（ソート法）
Sub Macro1()
d = Range("A65536").End(xlUp).Row
Range("A1:B" & d).Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Range("C14").Select
'---以上は第1行目以外はマクロの記録
k = 1
m = Cells(1, "A")
t = 0
For i = 1 To d
If Cells(i, "A") = m Then
t = t + Cells(i, "B")
Else
Cells(k, "F") = m
Cells(k, "G") = t
k = k + 1
m = Cells(i, "A")
t = Cells(i, "B")
End If
Next i
Cells(k, "F") = m
Cells(k, "G") = t
End Sub
for以下は常套手法です。

お礼

回答ありがとうございます。
参考にします。

回答No.2

chibita_papa

キー記録を使ってピボットテーブルをで作成してみたらどうですか

列名1 列名2
AAA 1
BBB 3
CCC 4
BBB 4
DDD 2
AAA 5
AAA 1

Sub Macro1()
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Sheet1!A1:B" & Range("A65536").End(xlUp).Row).CreatePivotTable TableDestination:= _
"[Book1]Sheet1!R1C5:R1C6", TableName:="ピボットテーブル1"
With ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("列名1")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("ピボットテーブル1").AddDataField ActiveSheet.PivotTables( _
"ピボットテーブル1").PivotFields("列名2"), "データの集計", xlSum
Range("F5").Select
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
End Sub

お礼

回答ありがとうございます。

ピボットテーブルなんて機能があったんですね。
参考にします。