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

質問

お世話になります。
下記は質問内容の現在の出力マクロです
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
前回質問からCD等もろもろ手抜きで書いたため少し違っています。
伝わるか心配ですが書き込みますので宜しくお願いします。
例、B列の重複した会社名C列の重複した支店加入者名D列の重複した班名そしてG列には重複した変更可能な重複した商品があります。重複したものをまとめてそれぞれに合計を出してBooks.AddのSheet1（現在はSheet1~sheet3に出力）に出力したいのです。その他の列は自動で出るように関数が張り付けてありますが質問には関係ないと思いますので割愛します。
つたない質問で申し訳ありませんがわかる方がありましたら回答をお願いします。
尚、（現在はSheet1~sheet3に出力）これではsheet1~sheet3を行ったり来たりで効率が悪くて困っています。宜しくお願いします

回答No.7

ushi2015

こんにちは
添付された画像のセル位置と、求める結果の表を提示してみて下さい。

お礼

有難うございます、画像を添付するにはここを一旦終了しなくてはなりませんね。また、新しくエクセルVBARange３か所に合致する合計額３として質問を立ち上げますので宜しくお願いします。

回答No.6

ushi2015

こんにちは
元のデータ範囲はA1:L5としてあります。
もし、A2:L6なら、
Set t = tsh.Range("A1").CurrentRegion.Resize(, 12)
を
Set t = tsh.Range("A2").CurrentRegion.Resize(, 12)
とするか、
Set t = tsh.Range("A2:L6")
として試して下さい。

お礼

有難うございます試してみましたがダメでした。

回答No.5

ushi2015

こんにちは
結果例が有れば分かりやすいのですが、
Private Sub CommandButton32_Click()
　　Dim wBK As Workbook
　　Dim tsh As Worksheet
　　Dim t　　 As Range
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim v　　 As Variant
　　Dim s　　 As String
　　Dim k　　 As String
　　Unload Me
　　Set tsh = ThisWorkbook.Worksheets("入力")
　　Set t = tsh.Range("A1").CurrentRegion.Resize(, 12)
　　k = t.Columns(12).Address(1, 1, 1, 1)
　　Set wBK = Workbooks.Add
　　v = Array(10, 2, 4)
　　For i = 1 To 3
　　　　With wBK.Worksheets("Sheet1")
　　　　　　j = i * 2 - 1
　　　　　　t.Columns(v(i - 1)).Cells(1, 1).Copy .Cells(1, j)
　　　　　　t.Columns(v(i - 1)).AdvancedFilter xlFilterCopy, , .Cells(1, j), True
　　　　　　s = t.Columns(v(i - 1)).Address(1, 1, 1, 1)
　　　　　　With .Range(.Cells(2, j), .Cells(Rows.Count, j).End(xlUp)).Offset(, 1)
　　　　　　　　.Formula = "=SUMIF(" & s & "," & _
　　　　　　　　　　wBK.Worksheets("Sheet1").Cells(2, j).Address(0, 1, 1, 1) & "," & k & ")"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　　　.Cells(1, j).Offset(, 1) = t.Range("L1")
　　　　End With
　　Next
End Sub
こんな感じですか？

お礼

有難うございます。

補足

親切にお付き合い下さいまして本当に感謝しています。結果新規ブックのB2,D2,F2にそれぞれ０が付きます。先に私がアップしたdic1に１列追加して結果合計は出せないものでしょうか？
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
私には能力不足で考えが出ません、宜しくお願いします

回答No.4

ushi2015

こんにちは
Private Sub CommandButton32_Click()
　　Dim wBK　 As Workbook
　　Dim tsh　 As Worksheet
　　Dim t　　 As Range
　　Dim i　　 As Long
　　Dim v　　 As Variant
　　Dim s　　 As String
　　Dim k　　 As String
　　Unload Me
　　Set tsh = ThisWorkbook.Worksheets("入力")
　　Set t = tsh.Range("A1").CurrentRegion.Resize(, 12)
　　k = t.Columns(12).Address(1, 1, 1, 1)
　　Set wBK = Workbooks.Add
　　v = Array(10, 2, 4)
　　For i = 1 To 3
　　　　With wBK.Worksheets("Sheet" & i)
　　　　　　t.Columns(v(i - 1)).Cells(1, 1).Copy .Range("B3")
　　　　　　t.Columns(v(i - 1)).AdvancedFilter xlFilterCopy, , .Range("B3"), True
　　　　　　s = t.Columns(v(i - 1)).Address(1, 1, 1, 1)
　　　　　　With .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
　　　　　　　　.Formula = "=SUMIF(" & s & ",B4," & k & ")"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　　　.Range("C3").Value = t.Range("L1")
　　　　End With
　　Next
End Sub
これで、どうでしょうか？
Dictionaryでもループする部分は流用出来ると思います。

お礼

有難うございます。

補足

新規ブックSheet1,2,3にRange("C1")に０、Range("C２")に０、Range("C４")に０、Range("B3")にはセルのコピーされたものが張り付いています。私の希望は現在出力されているsheet1,2,3を１つのsheetに会社１の支店加入者名＝合計額というようなマクロがほしいのですが....
表現力不足でごめんなさい。宜しくお願いします

回答No.3

ushi2015

こんにちは
2003じゃダメですね。
Dictionaryでまとめるのも出来ますけど、
また後で、フィルタオプション方式に書き換えてアップしますね。

お礼

有難うございます。

回答No.2

ushi2015

こんにちは
済みません、Excelのバージョンはなんでしょうか？

お礼

有難うございます、慌て者でごめんなさい。

補足

あ！ごめんなさい！先に書いておくべきでした、２００３です。２０１３の方はインデックスが違うのでまだ試していません。

回答No.1

ushi2015

こんにちは
どこが非効率なのか良く分かりませんが、
Private Sub CommandButton32_Click()
　　Dim wBK　As Workbook
　　Dim tsh 　As Worksheet
　　Dim t　　 As Range
　　Dim i　　 As Long
　　Dim v　　 As Variant
　　Dim s　　 As String
　　Dim k　　 As String
　　Unload Me
　　　　Set tsh = ThisWorkbook.Worksheets("入力")
　　Set t = tsh.Range("D2").CurrentRegion.Resize(, 12)
　　k = t.Columns(12).Address(1, 1, 1, 1)
　　Set wBK = Workbooks.Add
　　v = Array(10, 2, 4)
　　For i = 1 To 3
　　　　With wBK.Worksheets("Sheet" & i)
　　　　　　t.Columns(v(i - 1)).Copy .Range("B3")
　　　　　　s = t.Columns(v(i - 1)).Address(1, 1, 1, 1)
　　　　　　.Range("B3").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
　　　　　　With .Range("B4", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
　　　　　　　　.Formula = "=SUMIF(" & s & ",B4," & k & ")"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　　　.Range("C3").Value = t.Range("L1")
　　　　End With
　　Next
End Sub
とかでも、出来ますか？

お礼

ご回答ありがとうございます、早速試しましたがオブジェクトはこのプロバテイはサポートしていません。と　この部分で.Range("B3").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYesエラーが出ました。宜しくお願いします