◆◆プログラム解読◆◆

質問

Sub Sample()

'◆元々のデータ列数（A列～D列）
Const clngColumns As Long = 30
'◆グループの有る列(A列のA列からの列Offset)
Const clngGroup As Long = 0
'◆転記する列数（A列～Z列）
Const clngTransfer As Long = 30
'◆結果出力の先頭位置
Const cstrTop As String = "A1"

Dim i 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 vntGroup As Variant
Dim strProm As String

'画面更新を停止
Application.ScreenUpdating = False

'◆Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")

With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim vntData(1 To lngRows, 1 To 1)
For i = 1 To lngRows
vntData(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns) _
.Resize(lngRows).Value = vntData
'データをA列で整列
DataSort .Offset(1).Resize(lngRows, _
clngColumns + 1), .Offset(, clngGroup)
'A列データを配列に取得
vntGroup = .Offset(1, clngGroup) _
.Resize(lngRows + 1, 2).Value '修正
'列見出し範囲を取得
Set rngHeader = .Resize(, clngTransfer)
'列幅を取得
ReDim vntColumnWidth(clngTransfer - 1)
For i = 0 To clngTransfer - 1
vntColumnWidth(i) _
= .Offset(, 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
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vntGroup(lngTop, 2) '修正
Set rngResult = ActiveSheet.Range("A2")
rngHeader.Copy rngResult.Offset(-1)
'データを転記
rngList.Offset(lngTop).Resize(lngCount, _
clngTransfer).Copy Destination:=rngResult
'注目値の位置を記録
lngTop = i
'データ行数のカウント初期値に
lngCount = 1
Else
'データ行数のカウントを更新
lngCount = lngCount + 1
End If
Next i

With rngList
'元データを復帰
DataSort .Offset(1).Resize(lngRows, _
clngColumns + 1), .Offset(1, clngColumns)
'復帰用Key列を削除
.Offset(, clngColumns).EntireColumn.Delete
End With

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

回答No.1

kuni-chan

何を回答すれば良いのでしょうか？

お礼

大変失礼いたしました、途中でアップしていましたので、改めてご質問いたします。