| |
かな？
集計データがSheet1に有リ、列見出しが有るとします
結果をSheet2に出力します
Option Explicit
Public Sub AddUp()
'集計列数を設定
Const clngCol As Long = 3
'データ列数を設定
Const clngData As Long = 2
Dim i As Long
Dim lngRow As Long
Dim rngListTop As Range
Dim dicIndex As Object
Dim vntResult() As Variant
Dim vntData As Variant
Dim lngIndex As Long
Dim lngNumb As Long
'A列の列見出しの位置を基準とする
Set rngListTop = Worksheets("Sheet1").Cells(1, "A")
'基準位置に就いて
With rngListTop
'データ行数を取得
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
End With
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'Dictionaryに就いて
With dicIndex
'列位置の初期値
lngNumb = 1
'データ行全てに繰り返す
For i = 1 To lngRow
'列見だしが無い場合
' For i = 0 To lngRow
'A列以降のセルの値を配列に取得
With rngListTop
vntData = .Offset(i).Resize(, clngData).Value
End With
'DictionaryにKey名が有った場合
If .Exists(vntData(1, 1)) Then
'結果配列の列位置を取得
lngIndex = .Item(vntData(1, 1))
'Keyの有る行の個数列にデータの個数を加算
vntResult(2, lngIndex) _
= vntResult(2, lngIndex) + 1
'Keyの有る行のB列の値を加算
vntResult(3, lngIndex) _
= vntResult(3, lngIndex) + vntData(1, 2)
'担当名が無い場合
Else
'DictionaryにKey名と列位置（配列の）を追加
.Add vntData(1, 1), lngNumb
'結果用配列を拡張
ReDim Preserve vntResult(1 To clngCol, 1 To lngNumb)
'果用配列に、値を代入
vntResult(1, lngNumb) = vntData(1, 1)
vntResult(2, lngNumb) = 1
vntResult(3, lngNumb) = vntData(1, 2)
'列位置を更新
lngNumb = lngNumb + 1
End If
Next i
End With
'Dictionaryを破棄
Set dicIndex = Nothing
'結果をSheet2に出力
With Worksheets("Sheet2").Cells(1, "A")
.Resize(UBound(vntResult, 2), _
UBound(vntResult, 1)).Value _
= Application.Transpose(vntResult)
End With
Set rngListTop = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
|
|
Hirofumi
- 04/11/7(日) 8:52 -
