| |
今一、不明な点がありますが？
Option Explicit
Public Sub Sample()
'◆dataのデータ列数（A列〜C列）
Const clngColumns As Long = 3
'◆「機種名」の有る列(A列のA列からの列Offset)
Const clngGroup As Long = 0
'◆転記先の連番出力列位置を設定
'(基準位置からの列Offset：A列)
Const clngNumb As Long = 0
'◆転記先の「機種名」出力列位置を設定
'(基準位置からの列Offset：B列)
Const clngItem As Long = 1
'◆転記先の「連番」「機種名」出力行位置を設定
'(基準位置からの行Offset：6行)
Const clngRow As Long = 5
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngTop As Long
Dim lngCount As Long
Dim rngList As Range
Dim rngResult As Range
Dim rngHeader As Range
Dim lngSerial As Long
Dim lngWrite As Long
Dim vntGroup As Variant
Dim vntMark As Variant
Dim vntPost As Variant
Dim lngOffset As Long
Dim strProm As String
'◆転記元列を転記元基準位置からの列Offsetで指定
'「品番」B列＝1、「数量」C列＝2
vntMark = Array(1, 2)
'◆転記先列を転記先基準位置からの列Offsetで指定
'「品番」A列＝0、「数量」E列＝4
vntPost = Array(0, 4)
'画面更新を停止
Application.ScreenUpdating = False
'◆Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("data").Range("A1")
'◆formの転記範囲を指定
Set rngHeader = Worksheets("form").Range("A1:S8")
'formの行数取得
lngOffset = rngHeader.Rows.Count
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データをA列で整列
DataSort .Offset(1).Resize(lngRows, clngColumns), .Offset(, clngGroup)
'A列データを配列に取得
vntGroup = .Offset(1, clngGroup).Resize(lngRows + 1).Value
End With
'転記先の基準位置を設定
With rngList.Parent.Parent
Set rngResult = .Worksheets.Add(After:=rngList.Parent).Range("A1")
End With
'列幅を設定
With rngHeader
For i = 1 To .Columns.Count
rngResult.Offset(, i - 1).EntireColumn.ColumnWidth _
= .Cells(1, i).EntireColumn.ColumnWidth
Next i
End With
'注目値の位置を記録
lngTop = 1
'データ行数のカウント初期値
lngCount = 1
For i = 2 To lngRows + 1
'注目値と現在値が違った場合
If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
'Headerを出力
rngHeader.Copy Destination:=rngResult.Offset(lngWrite)
'「連番」、「機種名」を出力
With rngResult
.Offset(lngWrite + clngRow, clngItem).Value = vntGroup(lngTop, 1)
With .Offset(lngWrite + clngRow, clngNumb)
lngSerial = lngSerial + 1
.NumberFormatLocal = "000000"
.Value = lngSerial
End With
'出力位置を更新
lngWrite = lngWrite + lngOffset
'「品番」、「数量」データを転記
For j = 0 To UBound(vntMark)
.Offset(lngWrite, vntPost(j)).Resize(lngCount).Value _
= rngList.Offset(lngTop, vntMark(j)).Resize(lngCount).Value
Next j
'出力位置を更新
lngWrite = lngWrite + lngCount
End With
'注目値の位置を記録
lngTop = i
'データ行数のカウント初期値に
lngCount = 1
Else
'データ行数のカウントを更新
lngCount = lngCount + 1
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set rngHeader = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
