シートの並べ替えを実行するExcelVBAコード

スポンサーリンク

シートの並べ替えの機能は難しい

前回までにシートのたくさんあるファイルを使いやすくする目的で、シートの一覧を取得するExcelVBAコードシートを絞り込み表示するExcelVBAコードを紹介しました。
今回はより便利にシートを移動できるようにシート名に従って並べ替えをする機能を考えてみました。

行の並べ替えなどシートの中のデータを並べ替えるのはExcel機能があるので簡単ですが、シート自体を何らかの基準で並べ替える機能は調べたところなかったです。
Excelの標準の機能ではないのでExcelVBAで作成したのですが、並べ替えの仕組みが泥臭い感じになってしまいました。
でもまあとりあえず使える状態になりましたので紹介します。

シートの並べ替えの仕様について

ワークシートについては以前から使用しているように下記のようなものを作成しました。

130-1

VBAでシート名一覧を取得して、取得したシート名一覧を並べ替えて「表の順に並べ替え」ボタンでシートを表の順に並べ替えます。
また、単純な昇順・降順に関しては「シート昇順並べ替え」・「シート降順並べ替え」ボタンを用意して、シート一覧を編集する手間を省いています。

スポンサーリンク

シートの並べ替えを行うExcelVBAコード

私が作成したシート並べ替え用のExcelVBAコードは下記の通りです。

Sub シートの並べ替え()

Dim i, x, y, s
’シート名一覧を絞り込んでいるなら中止
If ActiveSheet.AutoFilterMode = True Then
MsgBox “絞り込みを解除してから実行してください”
Exit Sub
End If

’シート名一覧の開始位置をxとする
For i = 1 To Cells(1000000, 1).End(xlUp).Row
If Cells(i, 1) = “シート名” Then
x = i
Exit For
End If
Next i

’シート名一覧の開始位置が取得できなければ終了
If x = 0 Then Exit Sub

’抽出用シートのシート番号をyとする
For i = 1 To Worksheets.Count
If Sheets(i).Name = ActiveSheet.Name Then
y = i
Exit For
End If
Next i

’B列に現在のシートの並び順を一覧にする
For i = y + 1 To Worksheets.Count
Cells(i - y + x, 2) = Sheets(i).Name
Next i

’実際のシート数と一覧表のシート数が一致していないと中止
If Cells(Rows.Count, 1).End(xlUp).Row <> Cells(Rows.Count, 2).End(xlUp).Row Then
MsgBox “シートの数が一致していないので並べ替えできません”
Range(Cells(x + 1, 2), Cells(Rows.Count, 2).End(xlUp)).ClearContents
Exit Sub
End If

Do
’B列をいったん空欄にする
Range(Cells(x + 1, 2), Cells(Rows.Count, 2).End(xlUp).Offset(0, 3)).ClearContents
’シートの最後から順にチェックする
For i = Worksheets.Count To y + 1 Step -1
’並べ替えたい順序のA列と異なるところまで、現在のシート一覧をB列に作成する
Cells(i - y + x, 2) = Sheets(i).Name

’並べ替える必要があるシートは「1」、必要がないシートは「0」をC列に記入
If Cells(i - y + x, 1).Text <> Cells(i - y + x, 2).Text Then
Cells(i - y + x, 3) = 1
’エラーが生じた場合はメッセージボックスを表示して処理を中断する
On Error GoTo エラー処理
’並べ替えが必要なシートについて、並べ替え先のシート位置をMatch関数で取得
’数値で取得できるので移動先にうまく指定できれば時短になるが、無限ループの可能性あるのでこの数値は使用しない
Cells(i - y + x, 4) = Application.WorksheetFunction.Match(Cells(i - y + x, 2).Text, Range(Cells(x + 1, 1), Cells(Rows.Count, 1).End(xlUp)), 0)
On Error GoTo 0

’シートを最初に移動
Sheets(i).Move after:=Sheets(y)
Sheets(y).Select
’シート一覧が並べ変わるためやり直し
Exit For

Else
Cells(i - y + x, 3) = 0
End If

Next i

’シート一覧(B列)と並び替えたい一覧(A列)が一致しているかどうかのフラグをC3に入力
Cells(3, 3) = Application.WorksheetFunction.Sum(Range(Cells(x + 1, 3), Cells(Rows.Count, 3).End(xlUp)))

’シート一覧(B列)と並び替えたい一覧(A列)が一致するまで続ける
Loop Until Cells(3, 3) = 0

Range(Cells(3, 2), Cells(Rows.Count, 1).End(xlUp).Offset(0, 3)).ClearContents

Exit Sub
エラー処理:

MsgBox “シート名に誤りがあります”
Range(Cells(x, 2), Cells(1000000, 1).End(xlUp).Offset(0, 3)).ClearContents

End Sub

仕組みとしては下記①②を繰り返すものです。

  • ①並べたい順序のシート名一覧の隣のB列に現在のシート一覧を用意し、後ろから順にチェックする
  • ②一致していないシートを検索並べ替え用のシートの後に移動させる
  • また、シート名一覧が実際の数とずれていたり、シート名が一致するものがなければエラーになり中断するようにしています。

    本当はシート名と並び順を全部組み込んで適切な位置に一回で移動させる方が効率的なのですが、条件分岐が思いつかなかったのでとりあえず一番最初に移動させるフローにしています。
    このあたりは解消方法があればまたご紹介したいと思います。

    またシート昇順並べ替えには上記のExcelVBAコードを参照して下記のように作成しています。

    Sub シートの昇順並べ替え()

    ’シート名一覧を絞り込んでいるなら中止
    If ActiveSheet.AutoFilterMode = True Then
    MsgBox “絞り込みを解除してから実行してください”
    Exit Sub
    End If

    Dim i, x, y, s
    ’シート名一覧の開始位置をxとする
    For i = 1 To Cells(1000000, 1).End(xlUp).Row
    If Cells(i, 1) = “シート名” Then
    x = i
    Exit For
    End If
    Next i

    With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Cells(x, 1), Order:=xlAscending
    .SetRange Range(Cells(x, 1), Cells(Rows.Count, 1).End(xlUp))
    .Header = xlYes
    .Apply
    End With

    Call シートの並べ替え

    End Sub

    位置を決めて一覧表を並べ替えした後に、シートの並べ替えを実行する流れです。
    降順に関しては「Order:=xlAscending」を「Order:=xlDescending」に変更するだけです。

    コメント