◆2行づつソートする

  2行づつソートしたいと思ったことありませんか。

  たとえばこんな表です。

  
  かっこいい方法は知りません。
  
  以下は 2行づつのソートを力づくでやってみたサンプル です。

  選択されている表を自動判断して、2行ソートします。



  コメントに何をやっているのか詳しく記入しました。

  ダウンロードしたサンプル を動作させて、内容を理解してください。

  

Sub Sort()
    '選択されている範囲を2行毎にソートする
    '項目行は1行だけとする
    '選択されている範囲の一番左の項目でソートする

    Dim Book_Name As String
    Dim Sheet_Name As String
    Dim SelectArea As Range
    Dim SelectAddress As String
    Dim StartRow, StartColumn, MaxRow, MaxColumn As Integer
    Dim Current_MaxRow As Integer
    Dim i As Integer
    Dim FoundCell As Range
    
    Dim CopySource As Range
    Dim PasteDist As Range
    
    'アクティブな Book Sheet の名前を変数に代入
    Book_Name = ActiveWorkbook.Name
    Sheet_Name = ActiveSheet.Name
    
    '選択されている範囲を読み取る
    Set SelectArea = Selection
    
    SelectAddress = SelectArea.Address
    
    StartRow = SelectArea.Cells(1).Row
    StartColumn = SelectArea.Cells.Column
    
    MaxRow = SelectArea.Cells(SelectArea.Count).Row
    MaxColumn = SelectArea.Cells(SelectArea.Count).Column
    
    '2列追加する
    Range(Columns(StartColumn), Columns(StartColumn + 1)).Insert
    
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

    For i = StartRow + 1 To MaxRow Step 2
        ' & Format(i) は、セルの内容が同じ場合があるので、区別を付けるため
        Cells(i, StartColumn) = Cells(i, StartColumn + 2) & Format(i)
        Cells(i + 1, StartColumn) = Cells(i, StartColumn + 2) & Format(i)
        
        Cells(i, StartColumn + 1) = Cells(i, StartColumn + 2)
    Next
        
    '上記を実行するとこうなる
    'StartColumn列  StartColumn+1列
    'Y4mm           Y4
    'Y4mm           空白
    'R4nn           R4
    'R4nn           空白
    'W4yy           W4
    'W4yy           空白
    
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
    'ソートする表全体を選択する
    Range(Cells(StartRow, StartColumn), Cells(MaxRow, MaxColumn + 2)).Select
    'ソート
    Selection.Sort Key1:=Cells(StartRow + 1, StartColumn + 1), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, SortMethod:=xlPinYin
 
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
    '---------------------------------------
    'ソートした状態
    '---------------------------------------
    'StartColumn列  StartColumn+1列
    'R4nn           R4
    'W4yy           W4
    'Y4mm           Y4
    'R4nn   ←�@    空白
    'W4yy           空白
    'Y4mm           空白
    
    
    '---------------------------------------
    '上半分に行を挿入する
    '---------------------------------------
    'StartColumn列  StartColumn+1列
    'StartColumn列  StartColumn+1列
    'R4nn           R4
    '行を挿入
    'W4yy           W4
    '行を挿入
    'Y4mm           Y4
    '行を挿入
    'R4nn           空白
    'W4yy           空白
    'Y4mm           空白
 
    '�@の行番号を取得する
    '(MaxRow - StartRow)/2 + StartRow +1
    '          ↓
    '(MaxRow + StartRow)/2 +1
 
    For i = (MaxRow + StartRow) / 2 + 1 To StartRow + 2 Step -1
        Rows(i).Insert Shift:=xlDown
    Next
    
    
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'ソートすることで、取り残された行を追加した空白部分にコピーする
'

    'StartColumn列を文字属性にしておきます
    'Find(Cells(x,y))を使う場合、セルの属性が文字で無いと、
    '型の不一致で実行時エラーになる場合があるようです
    Columns(StartColumn).NumberFormatLocal = "@"

    '行を挿入後の最大の行数を取得
    Current_MaxRow = EffectiveRow_AssingColum_No(StartColumn)
    
    For i = MaxRow + 1 To Current_MaxRow
        
        
        Set CopySource = _
                     Range(Cells(i, StartColumn), Cells(i, MaxColumn + 2))
        
        
        Set FoundCell = Range(Cells(StartRow, StartColumn), _
                    Cells(MaxRow, StartColumn)).Find(Cells(i, StartColumn))
        If FoundCell Is Nothing Then
            'ここに来るはずがない
        Else
            Set PasteDist = _
            Range(Cells(FoundCell.Row + 1, StartColumn), _
                                   Cells(FoundCell.Row + 1, MaxColumn + 2))
            PasteDist.Value = CopySource.Value
        End If
    Next

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

    '追加した列を削除します
    Range(Columns(StartColumn), Columns(StartColumn + 1)).Delete

    '追加した行を削除します
    Range(Rows(MaxRow + 1), Rows(Current_MaxRow)).Delete

    '罫線を元に戻します
    For i = StartRow + 1 To MaxRow Step 2
    
        Range(Cells(i, StartColumn), Cells(i, MaxColumn)). _
                                Borders(xlEdgeBottom).LineStyle = xlNone

        With Range(Cells(i + 1, StartColumn), _
                           Cells(1 + 1, MaxColumn)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next

    Range("A1").Select
    
End Sub

Function EffectiveRow_AssingColum_No(col)
'   行の最大数を求める
'   Excelの最大行数(65536)から上方向(xlUp)に向かって空白でないセルを探す
    EffectiveRow_AssingColum_No = Cells(65536, col).End(xlUp).Row
End Function