| |
Excel本来の機能で出来るのだろうけど？
出力は、出力レイアウトが解らないので適当です
Option Explicit
Public Sub Sample()
'項目Aのデータ列数（A列〜I列）
Const clngColumns As Long = 9
'整列Key1列位置（B列、A列からの列Offset）
Const clngKeys1 As Long = 1
'整列Key2列位置（C列、A列からの列Offset）
Const clngKeys2 As Long = 2
Dim i As Long
Dim rngList As Range
Dim lngRows As Long
Dim vntList As Variant
Dim rngResult As Range
Dim lngWrite As Long
Dim vntTotal As Variant
Dim vntSubTotal As Variant
Dim vntWeekday As Variant
Dim strProm As String
'データのA1を基準とします（列見出しの「No.」セル位置）
Set rngList = ActiveWorkbook.Worksheets("作業用").Cells(1, "A")
With rngList.Parent.Parent
'「作業用（一覧）」出力のA1を基準とする
Set rngResult = .Worksheets("作業用(一覧)").Cells(1, "A")
End With
'画面更新を停止
Application.ScreenUpdating = False
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(65536 - .Row, _
clngKeys1 - 1).End(xlUp).Row - .Row
If lngRows < 0 Then
strProm = rngList.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'データをclngKeys1列で整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1, clngKeys1), Order1:=xlAscending, _
Key2:=.Offset(1, clngKeys2), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'データを配列に取得
vntList = .Offset(1, 1).Resize(lngRows + 1, clngColumns - 2).Value
'元データを復帰
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
End With
'「曜日別売上」の出力用配列を確保
ReDim vntWeekday(1 To 7, 1 To 3)
For i = 1 To 7
vntWeekday(i, 1) = Choose(i, "日曜", "月曜", "火曜", "水曜", "木曜", "金曜", "土曜")
Next i
'「大分類別売上」の出力用配列を確保
ReDim vntTotal(1 To 1, 1 To 4)
'「大分類＆小分類別売上」の出力用配列を確保
ReDim vntSubTotal(1 To 1, 1 To 4)
'列見出しを出力
rngResult.Offset(lngWrite).Resize(, 4).Value = Array("大分類", "小分類", "売上", "カウント")
'集計初期値設定
vntTotal(1, 2) = vntList(1, 1)
AddUp vntSubTotal, vntList, 1
vntWeekday(WeekDay(vntList(1, 3)), 2) = vntList(1, 7)
'集計出力
For i = 2 To lngRows + 1
'大分類が違ったら
If vntTotal(1, 2) <> vntList(i, 1) Then
'集計小分類の出力
OutputSubTotal vntTotal, vntSubTotal, rngResult, lngWrite
'「大分類別売上」の出力位置を更新
lngWrite = lngWrite + 1
'「大分類別売上」へ出力
vntTotal(1, 2) = "合計"
rngResult.Offset(lngWrite).Resize(, _
UBound(vntTotal, 2)).Value = vntTotal
'「大分類別売上」の出力用配列を確保
ReDim vntTotal(1 To 1, 1 To 4)
'集計初期値を代入
vntTotal(1, 2) = vntList(i, 1)
Else
'小分類が違ったら
If vntSubTotal(1, 2) <> vntList(i, 2) Then
'集計小分類の出力
OutputSubTotal vntTotal, vntSubTotal, rngResult, lngWrite
End If
End If
'小分類を集計
AddUp vntSubTotal, vntList, i
'「曜日別売上」を集計
vntWeekday(WeekDay(vntList(i, 3)), 2) _
= vntWeekday(WeekDay(vntList(i, 3)), 2) + vntList(1, 7)
vntWeekday(WeekDay(vntList(i, 3)), 3) _
= vntWeekday(WeekDay(vntList(i, 3)), 3) + 1
Next i
With rngResult
'列見出しを出力
.Offset(, 5).Resize(, 3).Value = Array("曜日別売上", "売上", "カウント")
'「曜日別売上」を出力
.Offset(1, 5).Resize(UBound(vntWeekday, 1), _
UBound(vntWeekday, 2)).Value = vntWeekday
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub AddUp(vntSum As Variant, vntList As Variant, lngPos As Long)
'大分類を代入
vntSum(1, 1) = vntList(lngPos, 1)
'小分類を代入
vntSum(1, 2) = vntList(lngPos, 2)
'売上を加算
vntSum(1, 3) = vntSum(1, 3) + vntList(lngPos, 7)
'カウントを加算
vntSum(1, 4) = vntSum(1, 4) + 1
End Sub
Private Sub OutputSubTotal(vntTotal As Variant, _
vntSubTotal As Variant, _
rngResult As Range, _
lngWrite As Long)
'大分類別売上集計用配列に小分類の売上、カウントを加算
vntTotal(1, 3) = vntTotal(1, 3) + vntSubTotal(1, 3)
vntTotal(1, 4) = vntTotal(1, 4) + vntSubTotal(1, 4)
'「大分類＆小分類別売上」の出力位置を更新
lngWrite = lngWrite + 1
'「大分類＆小分類別売上」へ出力
rngResult.Offset(lngWrite).Resize(, _
UBound(vntSubTotal, 2)).Value = vntSubTotal
'「大分類＆小分類別売上」の出力用配列を確保
ReDim vntSubTotal(1 To 1, 1 To 4)
End Sub
|
|
Hirofumi
- 06/5/21(日) 8:01 -
