| |
▼Hirofumi さん：
返信ありがとうございました。今回SSさんのほうを参考にさせてもらいました
次回このような機会がありましたら。またよろしくご教授ください。
tek
>ロットはどうするのだろう？
>
>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
|
|
tek
- 09/12/18(金) 3:17 -
