エクセルVBARange３か所に合致する合計額4

質問

画像が添付されていませんでしたので再度質問します。画像の上部が出力元データで下記が前回回答の結果の新規ブック出力画像です。上記は各列の内容を例的にしてあります。
行は３０００を超えているので短くしてあります。(y)ロシクお願いします。

回答No.4

ushi2015 · ベストアンサー

こんにちは
Sub test6()
　　Dim dic1 As Object
　　Dim r　　 As Range
　　Dim v　　 As Variant
　　Dim i　　 As Long
　　Dim sName As String

　　On Error Resume Next
　　Set r = Application.InputBox("データ範囲を項目行から最終行まで選択して下さい。", , , , , , , 8)
　　If r Is Nothing Then Exit Sub
　　On Error GoTo 0

'　　v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2
　　v = r.Value2

　　Set dic1 = CreateObject("Scripting.Dictionary")

　　For i = 1 To UBound(v)
　　　　sName = v(i, 10) & vbTab & v(i, 2) & vbTab & v(i, 4)
　　　　dic1(sName) = dic1(sName) + v(i, 12)
　　Next
　　Workbooks.Add
　　With Sheets("Sheet1").Range("B3").Resize(dic1.Count)
　　　　.Resize(, 2).Value = Application.Transpose(Array(dic1.Keys(), dic1.Items()))
　　　　.Offset(, 1).Resize(, 2).Insert
　　　　.TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, _
　　　　　　TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
　　　　　　Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
　　　　　　:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
　　End With
End Sub
こんな感じでしょうか？

お礼

完璧でした。長い間私のために時間を割いていただきありがとうございました。感謝です。

回答No.3

ushi2015

こんにちは
良く分からないので、標準モジュールにコード貼り付けて試して下さい。
元のデータ範囲も良く分からないので手作業で選択するようにしてあります。
Sub test5()
　　Dim dic1 As Object
　　Dim dic2 As Object
　　Dim dic3 As Object
　　Dim r　　 As Range
　　Dim v　　 As Variant
　　Dim i　　 As Long
　　Dim sName As String

　　On Error Resume Next
　　Set r = Application.InputBox("データ範囲を項目行から最終行まで選択して下さい。", , , , , , , 8)
　　If r Is Nothing Then Exit Sub
　　On Error GoTo 0

'　　v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2
　　v = r.Value2

　　Set dic1 = CreateObject("Scripting.Dictionary")
　　Set dic2 = CreateObject("Scripting.Dictionary")
　　Set dic3 = CreateObject("Scripting.Dictionary")

　　For i = 1 To UBound(v)
　　　　sName = v(i, 10)
　　　　dic1(sName) = dic1(sName) + v(i, 12)
　　　　sName = v(i, 2)
　　　　dic2(sName) = dic2(sName) + v(i, 12)
　　　　sName = v(i, 4)
　　　　dic3(sName) = dic3(sName) + v(i, 12)
　　Next
　　Workbooks.Add
　　With Sheets("Sheet1").Range("B3").Resize(dic1.Count)
　　　　.Resize(, 2).Value = Application.Transpose(Array(dic1.Keys(), dic1.Items()))
　　End With
　　With Sheets("Sheet1").Range("D3").Resize(dic2.Count)
　　　　.Resize(, 2).Value = Application.Transpose(Array(dic2.Keys(), dic2.Items()))
　　End With
　　With Sheets("Sheet1").Range("F3").Resize(dic3.Count)
　　　　.Resize(, 2).Value = Application.Transpose(Array(dic3.Keys(), dic3.Items()))
　　End With
End Sub

お礼

有難うございます、厄介者ですみません。

補足

やっぱり私の説明が足りないのですね自分ながら情けない。
確かにシート１に３列に出力できましたが本当に申し訳ありません。
Set dic1 = CreateObject("Scripting.Dictionary")から
Set dic2 = CreateObject("Scripting.Dictionary")
Set dic3 = CreateObject("Scripting.Dictionary")
を使うのではなく
Set dic1 = CreateObject("Scripting.Dictionary")このdic1１個でdic3までの合計が出せたらいいなと思いまして！
例えばどこの会社のどの会員の商品の値段=合計金額というようなVBAなのですが....

回答No.2

kagakusuki

しかも添付されている画像は文字が全て潰れてしまっていて、どこにどんなデータがあるのか全く分からない状態になっているのですから、その様な画像では添付しても意味がありません。
　もっと文字が大きく写っている画像を添付する様にして下さい。

お礼

有難うございます。次回は大きな文字で添付したいと思います。
ご指摘有難うございました。

回答No.1

kagakusuki

それで質問は何ですか？
　画像だけでは質問になりませんよ。
　ちゃんと何をしたいのかという事を書いて下さい。

>前回回答の結果

が出ているというのに、何が問題なのですか？
　そもそも、前回とは何の事なのですか？
　ご質問文中には何が前回なのか一言も書かれていませんよ。

お礼

有難うございます、いつもお世話になっています。

補足

お世話になります、下記は新規ブックにシーツ１，２，３に出力に出力させているのですが、これを１つのシートに３個のマクロではなく１個のマクロで１つのシートに合計したいのです。

Private Sub CommandButton32_Click()
Unload Me
Sheets("入力").Select
Set dic1 = CreateObject("Scripting.Dictionary")
　　Sheets("入力").Select
Set dic2 = CreateObject("Scripting.Dictionary")
Sheets("入力").Select
Set dic3 = CreateObject("Scripting.Dictionary")

v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2
For i = 1 To UBound(v)
sName = v(i, 10)
dic1(sName) = dic1(sName) + v(i, 12)
Next
v = Sheets("入力").Range("B2").CurrentRegion.Resize(, 12).Value2
For i = 1 To UBound(v)
sName = v(i, 2)
dic2(sName) = dic2(sName) + v(i, 12)
Next
v = Sheets("入力").Range("B2").CurrentRegion.Resize(, 12).Value2
For i = 1 To UBound(v)
sName = v(i, 4)
dic3(sName) = dic3(sName) + v(i, 12)
Next
Workbooks.Add
With Sheets("sheet1").Range("B3").Resize(dic1.Count)
.Resize(, 2).Value = Application.Transpose(Array(dic1.Keys(), dic1.Items()))
End With
With Sheets("sheet2").Range("B3").Resize(dic2.Count)
.Resize(, 2).Value = Application.Transpose(Array(dic2.Keys(), dic2.Items()))
End With
With Sheets("sheet3").Range("B3").Resize(dic3.Count)
.Resize(, 2).Value = Application.Transpose(Array(dic3.Keys(), dic3.Items()))
End With
End Sub
これを下記の１つのマクロでｓName=v(i,10)で１つの合計ですがこれを(i,10)と(i,2)の合計若しくは(i,10)と(i,2)と（i,4)の合計は出せないものでしょうか。

Private Sub CommandButton32_Click()
Unload Me
Sheets("入力").Select
Set dic1 = CreateObject("Scripting.Dictionary")
Sheets("入力").Select
v = Sheets("入力").Range("D2").CurrentRegion.Resize(, 12).Value2
For i = 1 To UBound(v)
sName = v(i, 10)
dic1(sName) = dic1(sName) + v(i, 12)
Next
Workbooks.Add
With Sheets("sheet1").Range("B3").Resize(dic1.Count)
.Resize(, 2).Value = Application.Transpose(Array(dic1.Keys(), dic1.Items()))
End With
End Sub
宜しくお願いします。