ＶＢＡ 2つの条件が一致すれば数値を合算

VBA初心者です。
データから必要なものだけを抽出するところまで進んだのですが、その後つまづいて前に進めません。
何度かトライしているのですがどうしても分かりません。お助けいただけると嬉しいです。

ｓｈｅｅｔ1にデータがあります。Ａ列とＢ列が一致した場合のみ、Ｃ列～Ｌ列の値を合算したいのです。問題点はＣ列～Ｌ列に空白セルが多数存在することです。

添付画像左側が処理前。右側が処理後の画像となっています。
処理はすべてｓｈｅｅｔ1で完結したいのですが、難しければ処理後を別シートでも構いません。

よろしくお願いします。

No.2 ベストアンサー 回答者： めぐみん_ 回答日時： 2018/06/07 06:13

うちのは古いExcelなのでSUMIFSが使えなくてちょっと面倒になってしまいましたが、

L列より右にはデータがない（空白で自由に使える）と言うのなら、

Sub megu()
Dim SL As Object, str As String
Dim r As Range, rr As Range
Dim i As Integer, v, vv

Application.ScreenUpdating = False

Set SL = CreateObject("System.Collections.SortedList")

With Worksheets("Sheet1")
.Range("C:C").EntireColumn.Insert
.Range("A1:M1").Copy .Range("Q1")

Set rr = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))

For Each r In rr
str = r.Value & "_" & r.Offset(, 1).Value
If Not SL.Contains(str) Then SL.Add str, str
r.Offset(, 2).Value = str
Next

For i = 0 To SL.Count - 1
v = Split(SL.GetKey(i), "_")
.Range("Q2").Offset(i).Value = v(0)
.Range("R2").Offset(i).Value = Val(v(1))
.Range("S2").Offset(i).Value = SL.GetKey(i)
Next

For i = 1 To 10
For Each r In .Range("S2", .Cells(Rows.Count, "S").End(xlUp))
vv = Application.SumIf(rr.Offset(, 2), r.Value, rr.Offset(, i + 1))
If vv <> 0 Then r.Offset(, i).Value = vv
Next
Next

.Range("A:P").EntireColumn.Delete
.Range("C:C").EntireColumn.Delete
End With

Application.ScreenUpdating = True

Set SL = Nothing
Set rr = Nothing
End Sub

こんな感じにSUMIF関数で頑張ってみました。
L列以降に作業列で表を作成し、元データの範囲を削除して入れ替えてます。

寝ぼけながら作ったのでミスしてたらごめんなさい。

この回答へのお礼

確認しましたら、無事うまくいきました。
ｖｂａは奥が深いなと思いました。同じ結果を導くのに色々な考え方があるので驚かされます。
何週間か悩んだことが、こんなにも早く解決できてうれしいです。
本当にありがとうございます。

お礼日時：2018/06/07 07:11

No.1 回答者： tom04 回答日時： 2018/06/06 22:45

こんばんは！

一例です。
元データはSheet1にあり、Sheet2に表示するとします。
標準モジュールにしてください。

Sub Sample1()
Dim myDic As Object
Dim i As Long, j As Long, lastRow As Long
Dim myStr As String, wS As Worksheet
Dim myKey, myItem, myR, myAry, myAry2

Set myDic = CreateObject("Scripting.Dictionary")
Set wS = Worksheets("Sheet2")
wS.Cells.ClearContents
With Worksheets("Sheet1")
wS.Range("A1:L1").Value = .Range("A1:L1").Value
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
myR = Range(.Cells(2, "A"), .Cells(lastRow, "L"))
For i = 1 To UBound(myR, 1)
myStr = myR(i, 1) & "_" & myR(i, 2)
myAry = Array(myR(i, 3), myR(i, 4), myR(i, 5), myR(i, 6), myR(i, 7), _
myR(i, 8), myR(i, 9), myR(i, 10), myR(i, 11), myR(i, 12))
If Not myDic.exists(myStr) Then
myDic.Add myStr, myAry
Else
myAry2 = myDic(myStr)
For j = 3 To 12
If myR(i, j) <> "" Then
myAry2(j - 3) = myAry2(j - 3) + myR(i, j)
End If
Next j
myDic(myStr) = myAry2
End If
Next i
End With
myKey = myDic.keys
myItem = myDic.items
For i = 0 To UBound(myKey)
myAry = Split(myKey(i), "_")
wS.Cells(i + 2, "A") = myAry(0)
wS.Cells(i + 2, "B") = myAry(1)
myAry2 = myItem(i)
For j = 0 To UBound(myAry2)
wS.Cells(i + 2, j + 3) = myAry2(j)
Next j
Next i
Set myDic = Nothing
wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes, _
key2:=wS.Range("B1"), order1:=xlAscending, Header:=xlYes
wS.Activate
MsgBox "完了"
End Sub

じっくり考えればもっと簡単になるかもしれませんが、
まずはこの程度で・・・m(_ _)m

この回答へのお礼

お返事遅くなり申し訳ありません。
標準モジュールで確認しましたら、無事うまくいきました。
ｔｏｍ０４さんいつも教えていただき本当にありがとうございます。

教えていただいた後でいつもプログラムを解読しているのですが、本当に感心させられます。

お礼日時：2018/06/07 07:02