| |
ロットはどうするのだろう？
Option Explicit
Public Sub Sample()
'Listのデータ列数（A列〜D列）
Const clngColumns As Long = 4
'Listの中のKey1と成る列位置(基準列からの列Offset：0列目)
Const clngKey1 As Long = 0
'Listの中のKey2と成る列位置(基準列からの列Offset：1列目)
Const clngKey2 As Long = 1
'Listの中の集計列位置(基準列からの列Offset：2列目)
Const clngItem As Long = 2
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntResult As Variant
Dim vntData As Variant
Dim lngTop As Long
Dim lngCount As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用Keyを設定
.Offset(, clngColumns).EntireColumn.Insert
With .Offset(1, clngColumns)
.Value = 1
.Resize(lngRows).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, Step:=1, Trend:=False
End With
'データを「品番」順の「納期」順で整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngKey1), Order1:=xlAscending, _
Key2:=.Offset(1, clngKey2), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
End With
'画面更新を停止
' Application.ScreenUpdating = False
'先頭行を結果用配列に取得
lngTop = 1
vntResult = rngList.Offset(lngTop).Resize(, clngColumns + 1).Value
'Key列に就いて繰り返し
For i = 2 To lngRows + 1
'1行分配列に取得
vntData = rngList.Offset(i).Resize(, clngColumns + 1).Value
'結果用配列と取得配列で「品番」「納期」が同値なら
If vntResult(1, clngKey1 + 1) = vntData(1, clngKey1 + 1) _
And vntResult(1, clngKey2 + 1) = vntData(1, clngKey2 + 1) Then
'結果用配列に加算
vntResult(1, clngItem + 1) = vntResult(1, clngItem + 1) _
+ vntData(1, clngItem + 1)
'ロット番号
vntResult(1, clngColumns) = CStr(vntResult(1, clngColumns)) _
& "; " & CStr(vntData(1, clngColumns))
'復帰用KeyをEmptyに
rngList.Offset(i, clngColumns).Value = Empty
'削除数を更新
lngCount = lngCount + 1
Else
'結果用配列を出力
rngList.Offset(lngTop).Resize(, clngColumns + 1).Value = vntResult
'同値先頭行位置を更新
lngTop = i
'取得配列を結果用配列に代入
vntResult = vntData
End If
Next i
With rngList
'復帰用Keyで整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'削除行が在る場合
If lngCount > 0 Then
'行削除
.Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
End If
'復帰用Keyを削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 09/12/16(水) 12:45 -
