| |
こんなかな？
Option Explicit
Public Sub Sample()
'データの入出力範囲
Const cstrScope As String = "D18:D30"
Dim i As Long
Dim j As Long
Dim k As Long
Dim vntData As Variant
Dim vntSum() As Variant
Dim strKeys() As String
Dim lngKeys As Long
Dim strKey As String
Dim lngPos As Long
Dim wksCurrent As Worksheet
Dim strProm As String
'Key探索用配列のサイズ初期値
lngKeys = -1
'全てのWorkSheetに就いて繰り返し
For Each wksCurrent In Worksheets
With wksCurrent
'シート名の"-"の位置を取得
lngPos = InStr(1, .Name, "-", vbTextCompare)
'"-"が有ったら
If lngPos > 0 Then
'D18:D30のデータを取得
vntData = .Range(cstrScope).Value
'集計位置探索のKeyを作成
strKey = Left(.Name, lngPos - 1)
'集計用配列の集計位置を探索
For j = 0 To lngKeys
If StrComp(strKeys(j), strKey, vbTextCompare) = 0 Then
Exit For
End If
Next j
'探索値が有った場合
If j <= lngKeys Then
'位置を保存
lngPos = j
'集計位置に加算
For j = 1 To UBound(vntData, 2)
For k = 1 To UBound(vntData, 1)
vntSum(lngPos)(k, j) _
= vntSum(lngPos)(k, j) + vntData(k, j)
Next k
Next j
Else
'集計用配列のサイズを更新
lngKeys = lngKeys + 1
'集計用配列、Key配列を拡張
ReDim Preserve vntSum(lngKeys), strKeys(lngKeys)
'集計用配列に値を代入
vntSum(lngKeys) = vntData
'Key配列にKeyを追加
strKeys(lngKeys) = strKey
End If
End If
End With
Next wksCurrent
'画面更新を停止
Application.ScreenUpdating = False
'Key全てに就いて繰り返し
For i = 0 To UBound(strKeys, 1)
'Keyに"合計"を付加
strKeys(i) = strKeys(i) & "合計"
Set wksCurrent = Nothing
'集計シートを探索
For Each wksCurrent In Worksheets
'Keyに対するシートが有った場合
If StrComp(wksCurrent.Name, strKeys(i), vbTextCompare) = 0 Then
'Forを抜ける
Exit For
End If
Next wksCurrent
'もし、シートが無い場合
If wksCurrent Is Nothing Then
'シートを追加して、シート名を変更
With Worksheets
Set wksCurrent = .Add(After:=.Item(.Count))
End With
wksCurrent.Name = strKeys(i)
End If
'集計データを出力
wksCurrent.Range(cstrScope).Value = vntSum(i)
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set wksCurrent = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 06/4/8(土) 15:16 -
