|
みなさん 今晩は。
前に作っていたのですが、タイミング遅すぎたのでそのままにしていました。
また、質問があったので、のせてみます。
別のやり方ですけど、試してみてください。
Sub main()
Dim u
u = Array(集計(1), 集計(2), 集計(3), 集計(4), 集計(5))
Sheets("結果シート").Cells(14, 5).Resize(UBound(集計(1)) + 1, UBound(u) + 1).Value _
= Application.Transpose(u)
End Sub
Private Function 集計(clmn As Long) As Variant
Dim rngA As Range
Dim Dic As Object
Dim r As Range
Set rngA = ActiveSheet.Range("A1", Range("A65536").End(xlUp))
Set Dic = CreateObject("Scripting.Dictionary")
For Each r In rngA.Cells
If clmn = 1 Then
Dic.Item(r.Text) = r.Text 'A列について
Else
Dic.Item(r.Text) = Dic.Item(r.Text) + r.Offset(, clmn - 1).Value
End If
Next
集計 = Dic.items()
'
Set r = Nothing
Set Dic = Nothing
Set rngA = Nothing
End Function
|
|