重複データの合算(VBA)

A列が文字列、B列～AB列が数字の羅列（1行目はタイトル行）
上記のようなデータがあります。
A列が重複する行は削除し、B列目以降は合算した結果をそれぞれの列に出したい(B列の合算はB列に、C列の合算はC列に・・・）と思っています。

下記コードはB列のみ合算するコードになっていますが、B列のみではなく、
B列～AB列を列毎に合算する構文にするにはどうすれば良いかご教授頂けないでしょうか。


Sub 重複データを削除し合計を合算()

Dim myDic As Object
Dim myKey As Variant
Dim myItem As Variant
Dim myList As Variant
Dim i As Long

Set myDic = CreateObject("Scripting.Dictionary")

'A列,AB列のデータを配列に格納
myList = Range("A2", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 28).Value

'連想配列にデータを格納
For i = 1 To UBound(myList, 1)

'コードが空欄かチェック
If Not myList(i, 1) = Empty Then
If Not myDic.exists(myList(i, 1)) Then

'重複しないコードを取得
myDic.Add Key:=myList(i, 1), Item:=myList(i, 2)
Else

'加算
myDic(myList(i, 1)) = myDic(myList(i, 1)) + myList(i, 2)
End If
End If
Next

'[コード] 重複していないリストを格納
myKey = myDic.keys

'[合計] 合計を格納
myItem = myDic.items

'リストを出力
For i = 0 To UBound(myKey)
Cells(i + 2, 31).Value = myKey(i)
Cells(i + 2, 32).Value = myItem(i)
Next

'開放
Set myDic = Nothing
End Sub

No.5 ベストアンサー 回答者： ママチャリ 回答日時： 2021/05/19 22:40

Consolidate メソッドで行けるかもです。

添付画像のような表であれば、こんなコードです。

Sub sample()
Range("F1").Consolidate Sources:="Sheet1!R1C1:R6C4", _
Function:=xlSum, TopRow:=True, LeftColumn:=True
End Sub

この回答へのお礼

ありがとうございます。
Consolidateは知りませんでした。勉強します。
意図通りの結果を高速で出すことが出来ました。

お礼日時：2021/05/22 15:13

No.7 回答者： めぐみん_ 回答日時： 2021/05/20 22:34

Consolidate メソッドなんてのもあるんですね。

初級者は余り機能とかよく見ずに作るから長くなるのでしょうね。

'開放
Set myDic = Nothing
Next '←追加

これですと変数：myDic はDictionaryから解放されますので次のループではDictionaryオブジェクトとして使えません。
データだけを消したいとお見受けしたのですが多分以下だと思います。

myDic.RemoveAll '←追加：全てのキーと項目を削除
Next '←追加
'開放
Set myDic = Nothing

この回答へのお礼

ありがとうございます。
初級者ですみません。頑張って勉強します。
ご教授頂いた内容＋下記を忘れていたので修正してループ処理で対応する事が出来ました。

For i = 0 To UBound(myKey)
Cells(i + 2, 31).Value = myKey(i)
Cells(i + 2, 30+j).Value = myItem(i)
Next

お礼日時：2021/05/22 15:17

No.6 回答者： tatsumaru77 回答日時： 2021/05/20 09:20

>A列が重複する行は削除し、B列目以降は合算した結果をそれぞれの列に出したい(B列の合算はB列に、C列の合算はC列に・・・）と思っています。

もし、そうなら、出力先は別のシートの方が良いと思いますが、いかがでしょうか。
その方が良い場合は、現在のシート名と出力先のシート名をご提示ください。

この回答へのお礼

ありがとうございます。
別シート出力でも問題ありません。
今回は質問に載せているコードのループ処理で対応する事が出来ました。

お礼日時：2021/05/22 15:16

No.4 回答者： fujillin 回答日時： 2021/05/18 15:52

こんにちは

すでに回答が出ていますが・・・

＞B列のみではなく、B列～AB列を列毎に合算する構文に
＞するにはどうすれば良いかご教授頂けないでしょうか。
ご提示のコードでは、加算する列を2（＝B列）固定で計算しているので、ご質問文のようになっています。
条件は同じなので、列を２～28までループ等で加算するようにすれば、全体を処理することが可能になるでしょう。


ご提示のコードは配列や連想配列を利用して計算していますが、以下は、エクセルのシートとその機能を利用して算出するごくプリミティブな例です。
ご参考までに。

Sub Sample_Q12365731()
Dim rng As Range, rng2 As Range, rng3 As Range
Const mxCol = 28
Const f = "=IF(@="""","""",SUMIF($A:$A,@,B:B))"

Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, mxCol)
Set rng2 = rng.Offset(, mxCol + 2)
rng2.Value = rng.Value
Set rng3 = rng2.Cells(2, 2).Resize(rng.Rows.Count - 1, mxCol - 1)

'　重複を削除
rng3.Columns(1).Offset(, -1).RemoveDuplicates Columns:=1, Header:=xlNo

'　同じ文字列の値を合計
rng3.FormulaLocal = Replace(f, "@", rng2.Cells(2, 1).Address(0, 1))
rng3.Value = rng3.Value
End Sub

この回答へのお礼

ありがとうございます。
VBA初心者ですが見よう見まねでループ処理の構文にしてみましたがエラーになってしまいました。根本的に間違っているでしょうか？

Dim i,j As Long

For j = 2 To 28 '←追加

For i = 1 To UBound(myList, 1)

If Not myList(i, 1) = Empty Then
If Not myDic.Exists(myList(i, 1)) Then'←2回目のループでここでエラー

myDic.Add Key:=myList(i, 1), Item:=myList(i, j) '←myList(i, 2)を変更
Else

myDic(myList(i, 1)) = myDic(myList(i, 1)) + myList(i, j) '←myList(i, 2)を変更

End If
End If
Next

myKey = myDic.keys

myItem = myDic.Items

For i = 0 To UBound(myKey)
Cells(i + 2, 31).Value = myKey(i)
Cells(i + 2, 32).Value = myItem(i)
Next

'開放
Set myDic = Nothing
Next '←追加

お礼日時：2021/05/19 10:34

No.3 回答者： めぐみん_ 回答日時： 2021/05/18 15:16

No.1です。

やっぱパワークエリですかぁ。
経験ないですけど、SQLで言うクエリ以上なのでしょうか？
フィールドが２８もあって各２７フィールド毎に計算結果を出すのってどうやれるのか興味はありますね。（必要ないのでそこまでは実践しませんが）

先に重複データを纏めておいて列毎にSUMIF関数って位しか思いつかない愚かな初級者ですし。

この回答へのお礼

ありがとうございます。
SUMIF関数もやろうと思いましたが、10000行ほどあって処理に時間が掛かる為、VBAで配列して一気に吐き出せば処理時間が短くなるのではと思い、質問させて頂きました。

お礼日時：2021/05/19 10:29

No.2 回答者： bonaron 回答日時： 2021/05/18 14:33

結果が欲しいだけなら

パワークエリがとっても簡単かと。

この回答へのお礼

ありがとうございます。
パワークエリ（2016から追加されたんですね。知らなかったです）やピボットテーブルも考えましたが、パソコンあまり知らない人でもボタン一つで結果が出せるようにとVBAでやろうとしていました。

お礼日時：2021/05/19 10:28

No.1 回答者： めぐみん_ 回答日時： 2021/05/18 13:47

いきなり多い列数よりも少なめからやった方が良いと思い（ダミーデータ作るのが面倒だったとは言いませんよ？）、Ａ～Ｅ列のデータをＨ～Ｊ列に書き出す方法なら、

Sub megu()
Dim myDic As Object
Dim st As String
Dim myList As Variant, v As Variant, vv As Variant
Dim i As Long, j As Long

Set myDic = CreateObject("Scripting.Dictionary")

myList = Range("A2", Cells(Rows.Count, "E").End(xlUp))

For i = 1 To UBound(myList, 1)
st = myList(i, 1)
vv = WorksheetFunction.Index(myList, i, 0)

If Not myDic.Exists(st) Then
myDic.Add st, vv
Else
v = myDic(st)
For j = 2 To UBound(vv)
v(j) = v(j) + vv(j)
Next
myDic(st) = v
End If

Next

Range("H1:L1").Value = Range("A1:E1").Value
With WorksheetFunction
Range("H2").Resize(myDic.Count, UBound(myList, 2)).Value = .Transpose(.Transpose(myDic.Items))
End With

Set myDic = Nothing

End Sub

参考にならない、もっと楽な回答が出てきたらスル～して下さいな。

この回答へのお礼

ありがとうございます。
行数が10000行ほどあるので処理に時間が掛かりますが、意図通りの結果を出すことが出来ました。

お礼日時：2021/05/19 10:26