ＶＢＡ 条件一致で数値合算

ＶＢＡ初心者です。
ネットを見たりして何度も確認しているのですが、どうしても行き詰ってしまったのでお助けお願いします。4つの条件が一致したら数値を合算しようと思っています。添付図のように4つの条件をひとつにまとめるところまでできましたが、最後の合算だけできません。

Ａ列に条件があり、Ｂ列に数値があります。Ｃ列以降はすべて空白列です。
行数は最大でも50行くらいまでです。

あとひとつだけ希望があるのですが、できればワークシートを追加せず同じワークシートの中で処理を済ませたいです。
よろしくお願いします。

No.4 ベストアンサー 回答者： tom04 回答日時： 2018/07/13 23:43

こんばんは！

No.2さんがおっしゃっているように、別シートへ集計した方が良いのではないでしょうか。
（元データが変化してしまうと、確認のしようがありません）

というコトで、元データはSheet1にありSheet2に表示するコードにしてみました。
データ数は極端に多くないというコトなので、一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim lastRow As Long, wS As Worksheet
　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　.Range("A:B").ClearContents
　　　　.Range("A1:B1").Value = wS.Range("A1:B1").Value
　　　　wS.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("A1"), unique:=True
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　With Range(.Cells(2, "B"), .Cells(lastRow, "B"))
　　　　　　.Formula = "=SUMIF(Sheet1!A:A,A2,Sheet1!B:B)"
　　　　　　.Value = .Value
　　　　　End With
　　　　　　.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
　　　End With
End Sub

※　↓のコードは余計なお世話になるかもしれませんが、
コードは長いですが、データ数が数万行あってもそんなに時間を要しない方法です。
（参考程度で・・・）

Sub Sample2()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim wS As Worksheet
　Dim myKey, myItem, myR
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:B").ClearContents
　　　With Worksheets("Sheet1")
　　　　wS.Range("A1:B1").Value = .Range("A1:B1").Value
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "B"))
　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　If Not myDic.exists(myR(i, 1)) Then
　　　　　　　　myDic.Add myR(i, 1), myR(i, 2)
　　　　　　　Else
　　　　　　　　myDic(myR(i, 1)) = myDic(myR(i, 1)) + myR(i, 2)
　　　　　　　End If
　　　　　　Next i
　　　End With
　　myKey = myDic.keys
　　myItem = myDic.items
　　　For i = 0 To UBound(myKey)
　　　　With wS.Cells(i + 2, "A")
　　　　　.Value = myKey(i)
　　　　　.Offset(, 1) = myItem(i)
　　　　End With
　　　Next i
　　wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes
　　Set myDic = Nothing
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

お返事ありがとうございます。
標準モジュールで、無事うまくいきました。

すごいです。この短い時間でしかも2つもコードを作成できるのにはびっくりです。今日朝9時からずーっとパソコンの前に座ってＶＢＡを考えているのですがなかなか進まなかったのですが･･･
みなさんに助けてもらって非常にうれしいです。

本当にありがとうございます。

お礼日時：2018/07/14 00:09

No.5 回答者： tom04 回答日時： 2018/07/14 07:55

No.4です。

投稿後気になったのですが、
＞添付図のように4つの条件をひとつにまとめるところまでできましたが

とありますが、元データは5列のデータなのですかね？
そうであればわざわざ一つの列にまとめなくてもそのままの状態で可能です。
前回の「Sample2」に少し手を加えるだけです。

前回同様元データはSheet1のA～E列にあり、Sheet2に表示するとします。
尚、1行目は項目名が入っているという前提です。
（A～D列は何らかの名目でE列が合計する数値列だとします。）

標準モジュールにしてみてください。

Sub Sample3()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myKey, myItem, myR, myAry
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:E").ClearContents
　　　With Worksheets("Sheet1")
　　　　wS.Range("A1:D1").Value = .Range("A1:D1").Value
　　　　wS.Range("E1") = "合計"
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "E"))
　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 3) & "_" & myR(i, 4)
　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　myDic.Add myStr, myR(i, 5)
　　　　　　　　Else
　　　　　　　　　myDic(myStr) = myDic(myStr) + myR(i, 5)
　　　　　　　　End If
　　　　　　Next i
　　　End With
　　myKey = myDic.keys
　　myItem = myDic.items
　　　For i = 0 To UBound(myKey)
　　　　myAry = Split(myKey(i), "_")
　　　　　With wS.Cells(i + 2, "A")
　　　　　　.Value = myAry(0)
　　　　　　.Offset(, 1) = myAry(1)
　　　　　　.Offset(, 2) = myAry(2)
　　　　　　.Offset(, 3) = myAry(3)
　　　　　　.Offset(, 4) = myItem(i)
　　　　　End With
　　　Next i
　　　Set myDic = Nothing
　　　'//▼A→B→C→D列の順の優先順位で並び替え（すべて昇順）//
　　　　With wS.Range("A1").CurrentRegion
　　　　　.Sort key1:=wS.Range("D1"), order1:=xlAscending, Header:=xlYes
　　　　　.Sort key1:=wS.Range("A1"), order1:=xlAscending, _
　　　　　　　　key2:=wS.Range("B1"), order1:=xlAscending, _
　　　　　　　　key3:=wS.Range("C1"), order1:=xlAscending, _
　　　　　　　　Header:=xlYes
　　　　End With
　　　'//▲ココまで//
　　　wS.Activate
　　　MsgBox "完了"
End Sub

こんな感じで大丈夫だと思います。m(_ _)m

この回答へのお礼

色々とありがとうございます。

ｖｂａは本当に色々なことができると感心させられます。
親切に教えていただいて本当にありがとうございます。

お礼日時：2018/07/14 08:15

No.3 回答者： tatsu99 回答日時： 2018/07/13 23:43

No2です。

以下のマクロを標準モジュールに登録してください。
-----------------------------------
Option Explicit
Public Sub 並べ替え加算()
Dim maxrow As Long
Dim dicT As Object '連想配列 キー：Ａ列　値：Ｂ列合計
Dim row As Long
Dim key As Variant
Dim i As Long
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
'Ａ列でソート
Range("A1").Sort key1:=Range("A1"), Header:=xlYes
maxrow = Cells(Rows.Count, "A").End(xlUp).row 'A列の最大行取得
'Ａ列の値をキーとして、連想配列に加算
For row = 2 To maxrow
key = Cells(row, 1).Value
If dicT.exists(key) = True Then
dicT(key) = dicT(key) + Cells(row, 2).Value
Else
dicT(key) = Cells(row, 2).Value
End If
Next
Rows("2:" & Rows.Count).ClearContents 'Sheetの2行以降をクリア
'Sheetへ出力
row = 2
For Each key In dicT
Cells(row, 1).Value = key
Cells(row, 2).Value = dicT(key)
row = row + 1
Next
End Sub

この回答へのお礼

ありがとうございます。
標準モジュールで試してみましたら、無事うまくいきました。

ＶＢＡで合算は非常に難しくて、何度コードを読み返してもしっかりと理解できないです。この合算のコードを考えているだけで6時間以上かかってもできませんでした。この短時間でこの完璧なコードを作成するのはすご過ぎです。ありがとうございました。

お礼日時：2018/07/13 23:56

No.2 回答者： tatsu99 回答日時： 2018/07/13 23:14

A列、Ｂ列を直接書き換えると、マクロ実行後、万が一、データ入力に誤りがあることに気が付くと、

元に戻せませんが、それで良いのでしょうか。（事前に必ずバックアップをとる前提なら問題ありませんが）
それでもよいなら、マクロ提供は可能です。

この回答へのお礼

お返事ありがとうございます。
戻せなくて大丈夫です。二重にバックアップしてあります。

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

お礼日時：2018/07/13 23:40

No.1 回答者： mabuterol 回答日時： 2018/07/13 22:14

1. A 列を昇順にソートする。

2. A 列の最後のセルが、A 列の他のセルと一致しているか否か、関数で判別する。
3. 一致していた場合は、一致していた先のセルと合算して、今の行を削除する。
この 2 と 3 をループさせたら、どうですか？

この回答へのお礼

早速のお返事ありがとうございます。
なんとなく理屈はわかるのですが、みなさんほどのスキルがないので
実際プログラムを記述するとなるとなかなかできなくて申し訳ありません。

お礼日時：2018/07/13 22:26