ここから本文です

Dictionaryで複数シートの同じ項目を集計したいのですが。 作業は、Excel2007でし...

es2024tjoyさん

2013/2/2217:21:03

Dictionaryで複数シートの同じ項目を集計したいのですが。
作業は、Excel2007でしています。

"Sheet"が4枚あり、Range("A2:D2")ー項目
Range("A3")から"D"列の最終行までデータが、入っています。(各'Sheet'同じです)

やりたい事は、各"Sheet"の2番目の項目("AA,BB,CC,DD,EE")の合計を、各"Sheet"のRange("F2:G2")の下に、一度にしたいのです。(画像が、下にあります)
コードは、

Sub Sample1()
Dim Dic As New Scripting.Dictionary
Dim mykey, myItem
Dim myval, sh As Worksheet
Dim i As Long, j As Long, k As Long, Ls As Long

For i = 1 To Sheets.Count

Set sh = Sheets("Sheet" & i)

myval = sh.Range("B3", Range("B" & Rows.Count).End(xlUp)).Resize(, 3).Value………★

For j = 1 To UBound(myval, 1)
If Not Dic.Exists(myval(i, 1)) Then
Dic.Add myval(j, 1), myval(j, 3)
Else
Dic(myval(j, 1)) = Dic(myval(j, 1)) + myval(j, 3)
End If
Next j

mykey = Dic.Keys
myItem = Dic.Items
For k = 0 To UBound(mykey)
sh.Cells(k + 3, 6).Value = mykey(i)
sh.Cells(k + 3, 7).Value = myItem(i)
Next k

Range("F2", Range("G" & Rows.Count).End(xlUp)).Sort _
Key1:=Range("F3"), _
Order1:=xlAscending, _
Header:=xlGuess

Next i
End Sub
と、書きました。

実行したところ
1枚目の'Sheet'では、集計できたのですが、2枚目は集計できず、

実行時エラー '1004'
'Range'メソッドは失敗しました。:_'Worksheet'オブジェクト
と、表示され、★の所が黄色く反転されます。

どう直したら良いのでしょうか?
判る方が、いらしゃれば教えて頂きたのですが。
宜しくお願いします。

補足シート(sh)を付けて実行したのですが。
"Sheet1"-"AA"
"Sheet2"-"BB"
"Sheet3"-"CC"
"Sheet4"-"DD"
の集計だけが、"F3:G7"にされただけに、なってしまうのですが。
どの様に直せば良いのでしょうか。
お手数、おかけします。

Rows.Count,Sheet&quot,Dic.Add myval,sh.Cells,MyItem,sh.Range,If Dic.Exists

閲覧数:
488
回答数:
2
お礼:
25枚

違反報告

ベストアンサーに選ばれた回答

ja7awuさん

編集あり2013/2/2411:59:25

--- 補足に対して---
> シート(sh)を付けて実行したのですが。
それは、質問時のコードのことだと思いますが・・・
それであれば、そこだけでなく他にもErrorになり実行出来ません。
> sh.Cells(k + 3, 6).Value = mykey(i)
この時点で i の値を看視すれば 良いかと思います。

こちらで、提示したコードでキチント集計されると思います。
コードを解析してみてください。
デバッグ手法は、必須ですので、習得しましょう。

-------------------

> 2枚目は集計できず、実行時エラー '1004'
> 'Range'メソッドは失敗しました。
それは、
> myval = sh.Range("B3", Range("B" & Rows.Count).End(~
                             ここ ↑ でシート(sh)の指定が無いからと思います。
現在ActiveなシートがSh以外は、Errorになると思います。

簡潔に記述して、こんな感じで如何でしょうか。
Scripting RunTime の参照を不要にしました。
シートを変えたとき Dic.RemoveAll しなして いいのですか?

Sub Sample2()
Dim Dic As Object
Dim Sh As Worksheet
Dim Rng As Range
Set Dic = CreateObject("Scripting.Dictionary")
For Each Sh In Worksheets
    Sh.Range("F3:G3").Resize(Rows.Count - 2).ClearContents
    Dic.RemoveAll
    For Each Rng In Sh.Range("B3", Sh.Cells(Rows.Count, 2).End(xlUp))
        If Dic.Exists(Rng.Value) Then
            Dic.Item(Rng.Value) = Dic.Item(Rng.Value) + Rng.Offset(, 2).Value
        Else
            Dic.Add Rng.Value, Rng.Offset(, 2).Value
        End If
    Next
    If Dic.Exists("") Then Dic.Remove ("")
    If Dic.Count > 0 Then
        Sh.Range("F3").Resize(Dic.Count).Value = _
                                Application.Transpose(Dic.Keys)
        Sh.Range("G3").Resize(Dic.Count).Value = _
                                Application.Transpose(Dic.Items)
    End If
    Sh.Range("F3").Resize(Dic.Count, 2).Sort Key1:=Sh.Range("F3"), _
            Order1:=xlAscending, Header:=xlNo
Next
MsgBox "単一化集計を完了しました。", vbInformation
Set Dic = Nothing
End Sub

質問した人からのコメント

2013/2/24 13:17:17

抱きしめる ja7awuさん、度々有難うございます。
mykey(i)を、デバッグで監視し、Dic.RemoveAllを、追加したところ、
無事、各Sheetに集計する事が出来ました。
rio koringoさん、アドバイス有難うございました。

又御縁があれば、お付き合い頂ければ幸いです。
有難うございました。

ベストアンサー以外の回答

1〜1件/1件中

rio_koringoさん

2013/2/2217:34:54

myval = sh.Range(sh.[B3], sh.Range("B" & Rows.Count).End(xlUp)).Resize(, 3).Value

とか?

あとDictionaryオブジェクトのアイテムは文字列になりますから

Dic(myval(j, 1)) = Val(Dic(myval(j, 1))) + myval(j, 3)

Val関数は必要かも?

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

5文字以上入力してください

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。