| |
前よりこっちの方が善いな
Option Explicit
Public Sub AddUp2()
'データの列数
Const clngColumns As Long = 6
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngRows As Long
Dim vntData As Variant
Dim vntResult() As Variant
Dim rngList As Range
Dim strProm As String
Dim lngWrite As Long
Dim vntSubTotal As Variant
Dim vntTotal() As Variant
Dim dicIndex As Object
Dim vntKey As Variant
Dim vntItem As Variant
Dim vntHeader As Variant
'Listの左上隅を基準とする
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows < 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'項目名を取得
vntHeader = .Resize(, clngColumns).Value
End With
'Dictionaryのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'商品コード別の店番別の集計
With dicIndex
'データの1行目から全ての行に就いて繰り返し
For i = 1 To lngRows
'行データを配列に取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'Keyを作成
vntKey = vntData(1, 1) & vbTab & vntData(1, 3)
'商品コード別の店番別で金額、消費税、合計を集計
If .Exists(vntKey) Then
'集計用配列の格納位置を取得
vntItem = .Item(vntKey)
'集計用配列に集計
For k = 4 To clngColumns
vntResult(k, vntItem) _
= vntResult(k, vntItem) + vntData(1, k)
Next k
Else
'集計用配列の添え字の最大値をインクリメント
j = j + 1
'集計用配列を拡張
ReDim Preserve vntResult(1 To clngColumns, 1 To j)
For k = 1 To clngColumns
vntResult(k, j) = vntData(1, k)
Next k
'dicIndexに登録
.Add vntKey, j
End If
Next i
End With
'Dictionaryのインスタンスを破棄
Set dicIndex = Nothing
Application.ScreenUpdating = False
'Sheet2に出力
'Listの左上隅を基準とする
Set rngList = Worksheets("Sheet2").Cells(1, "A")
With rngList
'項目を出力
.Resize(, clngColumns).Value = vntHeader
lngRows = UBound(vntResult, 2)
With .Offset(1).Resize(lngRows, clngColumns)
'データを出力
.Value = Application.Transpose(vntResult)
Erase vntResult
'データの整列
.Sort Key1:=.Item(1, 1), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
End With
End With
'小計、計を集計
'行挿入位置の初期値
lngWrite = 2
'総計出力用配列を確保
ReDim vntTotal(1 To clngColumns)
vntTotal(1) = "合計"
'小計出力用配列を確保
ReDim vntSubTotal(1 To clngColumns)
With rngList
'変数の初期値設定
vntData = .Offset(1).Resize(, clngColumns).Value
vntSubTotal(1) = vntData(1, 1)
vntSubTotal(2) = vntData(1, 2)
For j = 4 To clngColumns
vntSubTotal(j) = vntData(1, j)
Next j
'データの2行目から全ての行に就いて繰り返し
For i = 2 To lngRows
'行データを配列に取得
vntData = .Offset(lngWrite).Resize(, clngColumns).Value
'小計を取っている商品コードと現在の商品コードが同じなら
If vntSubTotal(1) = vntData(1, 1) Then
'小計を加算
For j = 4 To clngColumns
vntSubTotal(j) = vntSubTotal(j) + vntData(1, j)
Next j
Else
'小計を出力、総計にデータ追加
DataWrite rngList, lngWrite, vntSubTotal, vntTotal
'小計配列の初期値化
vntSubTotal(1) = vntData(1, 1)
vntSubTotal(2) = vntData(1, 2)
For j = 4 To clngColumns
vntSubTotal(j) = vntData(1, j)
Next j
End If
'行挿入位置をインクリメント
lngWrite = lngWrite + 1
Next i
End With
'小計を出力、総計にデータ追加
DataWrite rngList, lngWrite, vntSubTotal, vntTotal
'総計出力用配列を出力
rngList.Offset(lngWrite).Resize(, clngColumns).Value = vntTotal
Application.ScreenUpdating = True
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
Beep
MsgBox strProm
End Sub
Private Sub DataWrite(rngTop As Range, lngRow As Long, _
vntSubTotal As Variant, vntTotal As Variant)
'挿入行数
' Const lngInsert As Long = 2
Const lngInsert As Long = 1
Dim i As Long
'小計用配列を整える
vntSubTotal(1) = CStr(vntSubTotal(2)) & "計"
vntSubTotal(2) = Empty
With rngTop
'小計用配列を代入する行を挿入
.Offset(lngRow).Resize(lngInsert).EntireRow.Insert
'小計用配列を出力
.Offset(lngRow).Resize(, UBound(vntSubTotal)).Value = vntSubTotal
End With
'行挿入位置をインクリメント
lngRow = lngRow + lngInsert
'総計用配列にデータ追加
For i = 4 To UBound(vntTotal)
vntTotal(i) = vntTotal(i) + vntSubTotal(i)
Next i
End Sub
|
|
Hirofumi
- 05/4/10(日) 22:07 -
