シートを指定した順番で並べ替えるExcelマクロ

最近、Excelのシート何十枚かを指定された順番に並べ替えるという退屈極まりない作業を、しかも反復して行う羽目になりました。増えたワカメが戻るまでを眺めていた方がマシです。

窓を突き破る前にExcelマクロにチャレンジしてみました。

五十音順とかではなく、ある指定された順番だったので、どうしたものかと思いました。

スクリプトに直接書いてもいいのですが、なんとなくマクロのブックにシート『設定』を作成して、そこに「並べ替え対象のファイルパス」と「並べ替え後のシート名の順番」を書くことにしました。

こんなかんじ↓です。

シート『設定』
	A
1	C:\path\to\file.xlsx
2	シート名1
3	シート名2
4	シート名3
5	...

VBAがこうです。

Excel VBA

Sub シートを指定した順番でソートする()
    'このマクロがあるブックにシート『設定』を用意しておきます
    'A:1のセルに対象ファイル名を書きます
    'A:2～のセルに並べ替え後のシート名を順番に書きます
    Dim configSheet As Worksheet: Set configSheet = ThisWorkbook.Sheets("設定")

    'シート『設定』A:1セルに書かれたパスで対象のファイルを開きます
    Dim targetBook As Workbook
    Set targetBook = Workbooks.Open(configSheet.Cells(1, 1).Value)

    'シート『設定』のA列の値でリストを作ります
    Dim sortList() As String
    Dim sheetName As String
    Dim i As Integer: i = 1
    sheetName = configSheet.Cells(i + 1, 1).Value
    Do While sheetName <> "" '空セルが来たら終わり
        ReDim Preserve sortList(i)
        sortList(i) = sheetName
        i = i + 1
        sheetName = configSheet.Cells(i + 1, 1).Value
    Loop

    '作成したリストの順番でシートを並び替えます
    Dim currentSheet As Worksheet
    Dim sheetIndex As Integer: sheetIndex = 0
    For i = LBound(sortList) To UBound(sortList)
        sheetName = sortList(i)
        For sheetIndex = 1 To targetBook.Sheets.Count
            Set currentSheet = targetBook.Sheets(sheetIndex)
            If (currentSheet.Name = sheetName) Then
                currentSheet.Move After:=targetBook.Sheets(targetBook.Sheets.Count) '末尾にぽいぽい
                Exit For
            End If
        Next sheetIndex
    Next i
End Sub

恥ずかしながらアルゴリズム知らずなので、もっと効率の良いソート方法があるような気がしてなりません。

もし「並べ替え後のシート名の順番」の途中に空白セルがあったら、そこまでしか並び替えません。また、リストに名前が無かったシートは先頭に来ます。