ExcelVBA Dictionaryオブジェクト
こんにちは。
Dictionaryオブジェクトについて、ご教示いただきたく質問させていただきます。
あるCSVデータにおいて、A列に入力されている番号で重複をなくし、重複する番号については、B列(売上額)C列(利益額)それぞれの値を合計してSheet2に表示させるコード(test1)を書きました。データの行数が3万5千行ほどあるため、処理が終わるのに3分程かかります。
今後もデータは増えていくので、処理終了までの時間をもう少し短縮したく、自分なりに調べてみたところ、Dictionaryオブジェクトというものを知り、使用例を参考にしながら見よう見まねでコード(test2)を書いて試してみたところ、処理終了まで数秒となり、かなり短縮されました。
エラーも出ることなく処理できるものの、Dictionaryオブジェクトに対する理解がイマイチでして、コードの書き方等、問題ないかを知りたく質問させていただいた次第です。
よろしくお願いいたします。
------------------------------------------------------------------------------
Sub test1()
Dim i As Long
Dim lastRow As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
'不要データ削除
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Range("B:Q,S:W,Y:AF").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
'シート名変更・挿入
ActiveSheet.Name = "CSV"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "売利集計"
Set ws = Worksheets("売利集計")
wS.Cells.ClearContents
ws.Range("B1").Value = Worksheets("CSV").Range("B1")
ws.Range("C1").Value = Worksheets("CSV").Range("C1")
With Worksheets("CSV")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("A1"), unique:=True
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
With Range(ws.Cells(2, "B"), ws.Cells(lastRow, "B"))
.Formula = "=SUMIF(CSV!A:A,A2,CSV!B:B)"
.Value = .Value
End With
With Range(ws.Cells(2, "C"), ws.Cells(lastRow, "C"))
.Formula = "=SUMIF(CSV!A:A,A2,CSV!C:C)"
.Value = .Value
End With
End With
Application.ScreenUpdating = True
Set ws = Nothing
MsgBox "売利集計完了しました。"
End Sub
Sub test2()
Dim i As Long
Dim lastRow As Long
Dim ws As Worksheet
Dim c As Range
Dim dicS As Object
Dim dicP As Object
Application.ScreenUpdating = False
'不要データ削除
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Range("B:Q,S:W,Y:AF").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
'シート名変更・挿入
ActiveSheet.Name = "CSV"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "売利集計"
'番号別集計
Set ws = Worksheets("売利集計")
Set dicS = CreateObject("Scripting.Dictionary")
Set dicP = CreateObject("Scripting.Dictionary")
With Sheets("CSV")
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
dicS(c.Value) = dicS(c.Value) + Val(c.Offset(, 1).Value)
dicP(c.Value) = dicP(c.Value) + Val(c.Offset(, 2).Value)
Next
With Worksheets("売利集計")
.Columns("A:C").ClearContents
.Range("A1").Resize(, 3).Value = Worksheets("CSV").Range("A1").Resize(, 3).Value
.Range("A2").Resize(dicS.Count).Value = WorksheetFunction.Transpose(dicS.keys)
.Range("B2").Resize(dicS.Count).Value = WorksheetFunction.Transpose(dicS.Items)
.Range("C2").Resize(dicP.Count).Value = WorksheetFunction.Transpose(dicP.Items)
End With
End With
Set dicS = Nothing
Set dicP = Nothing
MsgBox "売利集計完了しました。"
End Sub
お礼
教えていただいた通りShapesコレクションを追加しましたが、Set MyR = Range(Obj.TopLeftCell, Obj.BottomRightCell) でエラーが出てしまいます。これはオブジェクト名が異なる場合でも同じエラーを吐きました。 そこでOn Error Resume Nextを追加する事により問題なく動作させる事が出来ました。 ありがとうございます。