| |
UO3 さんのコードだけで善いのでしょうが？
私のコードでは、以下と成ります
Option Explicit
Public Sub Sample_5()
' 数量集計版
'「受注データ」の列数設定(A〜F列)
Const clngColumns As Long = 6
'集列(「受注先」列)の列位置(基準セル位置からの列Offset：E列)
Const clngItems As Long = 5
'集列(「数量」列)の列位置(基準セル位置からの列Offset：D列)
Const clngItems2 As Long = 3
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntTop As Variant
Dim vntData As Variant
Dim vntKeys As Variant
Dim vntOrders As Variant
Dim lngMax As Long
Dim lngWrite As Long
Dim vntUnique As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Range("A1")
'結果出力の先頭セル位置を基準セル位置とする（先頭列の列見出しのセル位置）
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'整列Keyを作成(「受注年月日」を第0列として
'「受注年月日」、「商品ＣＤ」、「商品名」、「単価」を列挙)
vntKeys = Array(0, 1, 2, 4)
With rngResult
'シートをクリア
.Parent.Cells.ClearContents
'列見出しを出力
.Resize(, clngColumns).Value = rngList.Resize(, clngColumns).Value
.Offset(, clngColumns - 1).Value _
= .Offset(, clngColumns - 1).Value & "グループ"
End With
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'復帰用整列Keyを作成
With rngList.Offset(1, clngColumns)
.Value = 1
.Resize(lngRows).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False
End With
'整列順を設定
lngMax = UBound(vntKeys)
ReDim vntOrders(lngMax)
For i = 0 To lngMax
vntOrders(i) = xlAscending
Next i
'データ「受注年月日」、「商品ＣＤ」、「商品名」、「単価」順に取得
DataSort rngList.Offset(1).Resize(lngRows, clngColumns + 1), vntKeys, vntOrders
'Listの先頭〜最終で繰り返し
vntTop = rngList.Offset(1).Resize(, clngColumns).Value
'集計Listを作成
Unique vntUnique, vntTop(1, clngItems + 1), vntTop(1, clngItems2 + 1)
For i = 2 To lngRows + 1
'Listから1レコード分取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'配列の先頭から最終まで比較
For j = 0 To lngMax
If vntTop(1, vntKeys(j) + 1) <> vntData(1, vntKeys(j) + 1) Then
Exit For
End If
Next j
'前列一致した場合
If j > lngMax Then
''集計Listを作成
Unique vntUnique, vntData(1, clngItems + 1), vntData(1, clngItems2 + 1)
Else
'集計
AddUp vntTop(1, clngItems + 1), vntTop(1, clngItems2 + 1), vntUnique
'集計レコードを出力
lngWrite = lngWrite + 1
rngResult.Offset(lngWrite).Resize(, clngColumns).Value = vntTop
'配列の中身を入れ替え
vntTop = vntData
'集計Listを作成
vntUnique = Empty
Unique vntUnique, vntTop(1, clngItems + 1), vntTop(1, clngItems2 + 1)
End If
Next i
With rngList
'復帰用KeyをKeyとして整列
DataSort .Offset(1).Resize(lngRows, clngColumns + 1), _
Array(clngColumns), Array(xlAscending)
'削除Flag列を削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub Unique(vntList As Variant, vntData1 As Variant, vntData2 As Variant)
Dim i As Long
Dim lngMax As Long
If VarType(vntList) = vbVariant + vbArray Then
lngMax = UBound(vntList, 2)
For i = 1 To lngMax
If vntList(1, i) = vntData1 Then
Exit For
End If
Next i
If i > lngMax Then
lngMax = lngMax + 1
ReDim Preserve vntList(1, 1 To lngMax)
vntList(1, lngMax) = vntData1
vntList(0, lngMax) = vntData2
Else
vntList(0, i) = vntList(0, i) + vntData2
End If
Else
ReDim vntList(1, 1 To 1)
vntList(1, 1) = vntData1
vntList(0, 1) = vntData2
End If
End Sub
Private Sub AddUp(vntItem1 As Variant, vntItem2 As Variant, vntUnique As Variant)
Dim i As Long
Dim vntValue As Variant
Dim vntSum As Variant
vntValue = vntUnique(0, 1) & "/" & vntUnique(1, 1)
vntSum = vntUnique(0, 1)
For i = 2 To UBound(vntUnique, 2)
vntValue = vntValue & "、" & vntUnique(0, i) & "/" & vntUnique(1, i)
vntSum = vntSum + vntUnique(0, i)
Next i
vntItem1 = vntValue
vntItem2 = vntSum
End Sub
Private Sub DataSort(rngScope As Range, _
vntKeys As Variant, _
vntOrders As Variant)
Dim i As Long
Dim j As Long
Dim vntK As Variant
Dim vntO As Variant
Dim lngNum As Long
vntK = vntKeys
vntO = vntOrders
lngNum = -Int(-(UBound(vntK) + 1) / 3) * 3 - 1
ReDim Preserve vntK(lngNum), vntO(lngNum)
For i = UBound(vntOrders) + 1 To lngNum
vntO(i) = xlAscending
Next i
With rngScope
For i = lngNum To 0 Step -3
.Sort _
Key1:=.Cells(1, vntK(i - 2) + 1), _
Key2:=IIf(IsEmpty(vntK(i - 1)), vntK(i - 1), .Cells(1, vntK(i - 1) + 1)), _
Key3:=IIf(IsEmpty(vntK(i)), vntK(i), .Cells(1, vntK(i) + 1)), _
Order1:=vntO(i - 2), _
Order2:=vntO(i - 1), _
Order3:=vntO(i), _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
Next i
End With
End Sub
|
|
Hirofumi
- 10/2/22(月) 12:30 -
