| |
もう見ていないかな？
手動で操作する手順ほぼそのままで
Option Explicit
Public Sub Sample_1()
'Listのデータ列数（A列〜C列）
Const clngColumns As Long = 3
'分割位置と成る列位置(基準列からの列Offset：2列目＝C列)
Const clngSplit As Long = 2
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim lngKeys() As Long
Dim strProm As String
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = ActiveSheet.Range("A1")
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'整列Keyを作成
ReDim lngKeys(1 To lngRows, 1 To 1)
For i = 1 To lngRows
lngKeys(i, 1) = i
Next i
'Listの分割列以降をB列最終行の下にCut&Paste
.Offset(, clngSplit).Resize(lngRows, clngColumns - clngSplit).Cut _
Destination:=.Offset(lngRows, clngSplit - 1)
'現在の最終列の後ろ（C列）に連番を付加
.Offset(, clngSplit).Resize(lngRows).Value = lngKeys
.Offset(lngRows, clngSplit).Resize(lngRows).Value = lngKeys
'連番をKeyにListを整列
.Resize(lngRows * 2, clngColumns - clngSplit + 2).Sort _
Key1:=.Offset(, clngSplit), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'連番を消去
.Offset(, clngSplit).EntireColumn.ClearContents
'A列をMerge
For i = 1 To lngRows * 2 Step 2
.Cells(i, 1).Resize(2).Merge
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/9/7(火) 20:06 -
