| |
こんにちは。
Dictionaryの練習に作ってみました。
うまくいくかどうか自信はありませんが、試してみてください。
エラー処理などは、出来ていません。
Sub test()
Dim mySHnm As String
Dim NewSH As Worksheet
Dim SH As Worksheet
Dim myDic As Object
Dim myVal As Variant
Dim myVal2 As Variant
'「・・の合計」のシートの削除
Application.ScreenUpdating = False
For Each SH In ThisWorkbook.Worksheets
Application.DisplayAlerts = False
If Right$(SH.Name, 2) = "合計" Then
SH.Delete
End If
Application.DisplayAlerts = True
Next
'シートネームの左から3文字を辞書のkeyに、D18からD30をitemに格納
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To ThisWorkbook.Worksheets.Count
mySHnm = Left$(Sheets(i).Name, 3)
myVal = Sheets(i).Range("D18", Sheets(i).Range("D30")).Value
If Not myDic.exists(mySHnm) Then
myDic(mySHnm) = myVal
Else '同じkeyなら配列の足し算
myVal2 = myDic(mySHnm)
For j = 1 To UBound(myVal2)
myVal2(j, 1) = myVal2(j, 1) + myVal(i, 1)
Next
myDic(mySHnm) = myVal2
End If
Next
'key毎にシートを追加、itemの転記
For Each mykey In myDic.Keys
Set NewSH = Worksheets.Add(after:=Sheets(Sheets.Count))
With NewSH
.Name = mykey & "合計"
.Range("D18", .Range("D30")).Value = myDic(mykey)
End With
Next
Application.ScreenUpdating = True
Set myDic = Nothing: Set NewSH = Nothing
End Sub
|
|
ponpon
- 06/4/8(土) 12:12 -
