|
こんなのでは?
「コード」で整列して、1行づつ処理しています
Option Explicit
Public Sub Sample_1()
'Listの列数(A〜F列)
Const clngColumns As Long = 6
'Listの中の「コード」と成る列位置(基準列からの列Offset:0列目)
Const clngKey1 As Long = 0
Dim i As Long
Dim lngRows As Long
Dim lngWrite As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntSum As Variant
Dim vntTotal As Variant
Dim strProm As String
'【集計】の先頭セル位置を基準とする(先頭列の列見出しのセル位置)
Set rngList = Worksheets("集計").Range("A1")
'【合計集計】の結果出力の先頭セル位置を基準とする(先頭列の列見出しのセル位置)
Set rngResult = Worksheets("合計集計").Range("A1")
'画面更新を停止
Application.ScreenUpdating = False
'【集計】のListに就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'Listを「コード」順で整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1, clngKey1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
End With
'【合計集計】に就いて
With rngResult
'データをクリア
If .CurrentRegion.Rows.Count > 1 Then
Intersect(.CurrentRegion, .CurrentRegion.Offset(1)).ClearContents
End If
End With
'合計用の配列を確保
ReDim vntTotal(1 To clngColumns)
vntTotal(1) = "合計"
'【集計】のデータ先頭行を集計用配列に取得
vntSum = rngList.Offset(1).Resize(, clngColumns).Value
'【集計】のデータ2行目〜最終行+1まで繰り返し
For i = 2 To lngRows + 1
'1行分のデータを配列に取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'「コード」が同じなら
If vntData(1, clngKey1 + 1) = vntSum(1, clngKey1 + 1) Then
'「個数」「金額」を集計
vntSum(1, 5) = vntSum(1, 5) + vntData(1, 5)
vntSum(1, 6) = vntSum(1, 6) + vntData(1, 6)
Else
'合計を集計
vntTotal(5) = vntTotal(5) + vntSum(1, 5)
vntTotal(6) = vntTotal(6) + vntSum(1, 6)
'データを出力
lngWrite = lngWrite + 1
rngResult.Offset(lngWrite).Resize(, clngColumns).Value = vntSum
'読み込んだデータを集計用変数に代入
vntSum = vntData
End If
Next i
'合計を出力
lngWrite = lngWrite + 1
rngResult.Offset(lngWrite).Resize(, clngColumns).Value = vntTotal
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|