Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

45045 / 76732

←次へ　｜　前へ→


	【36694】Re:特定の文字列をシート名に含むシートのみ串刺し計算

ponpon - 06/4/8(土) 12:12 -


	引用なし

	パスワード

こんにちは。
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

2 hits

▼

【36692】特定の文字列をシート名に含むシートのみ串刺し計算 VBA☆ 06/4/8(土) 8:51