【エクセルVBA】シートを任意の順番にソートするVBA

あのー、Excelのシートをソートする方法ってありますか。

エクセルの標準機能では用意されていませんね。

そうですよねー。シートが10個以上あるんですけど並び変えないといけないんです。めんどうだなー。

では、マクロで解決しましょう！

Excelのシートをソートするマクロをご紹介します。
任意の順番にソート処理可能です。

マクロ機能が有効なExcelブック「.xlsm」を作成

Excelブック「.xlsm」の作成方法が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】マクロ機能が有効なExcelブック「.xlsm」の作り方

コードを標準モジュールに貼り付け

標準モジュールの開き方が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】標準モジュールの開き方

標準モジュールを開いて、下記のコードを貼り付けて下さい。

コード

シート名取得

Sub Aファイルを開く()
    Dim OpenFileName As String
    
    OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*")
    
    If OpenFileName = "False" Then
        
        MsgBox "キャンセルされました。処理を終了します。"
        
        End
        
    Else
        Workbooks.Open OpenFileName
    
    End If
    
End Sub
Sub Aシート名取得()
    Dim sh As Variant, flag As Boolean
    Dim ws As Worksheet
    Dim i As Long
    i = 0

    Call Aファイルを開く


    '画面更新停止
    Application.ScreenUpdating = False
    
    '確認ダイアログ停止
    Application.DisplayAlerts = False
    
    For Each sh In Sheets
        If sh.Name = "シート名一覧" Then
            flag = True
            Exit For
        End If
    Next sh
    
    If flag = True Then
    
        Dim rc As Integer
        
        'メッセージ表示
        rc = MsgBox("シート「シート名一覧」を上書きしますか？" & Chr(13) & "※この処理は戻せません。", vbYesNo + vbQuestion, "確認")
        
        If rc = vbYes Then
            '画面更新停止
            Application.ScreenUpdating = False
            
            'シート選択
            Worksheets("シート名一覧").Activate
        
            'シート削除
            ActiveSheet.Delete

            '画面更新停止
            Application.ScreenUpdating = True
            
            'メッセージ表示
            MsgBox "処理前のシート「シート名一覧」は削除済みです。"
            
            Call Aシート名取得2
            
        Else
            
            'メッセージ表示
            MsgBox "キャンセルされました。処理を終了します。"
        
        End If
        
    Else

        Call Aシート名取得2
        
    End If
    
    '画面更新再開
    Application.ScreenUpdating = True
    
End Sub
Sub Aシート名取得2()

    '画面更新停止
    Application.ScreenUpdating = False
    
    'シート追加
    Worksheets.Add before:=Worksheets(1)
    
    'シート名変更
    ActiveSheet.Name = "シート名一覧"
    
    'シート選択
    Worksheets("シート名一覧").Activate
    
    ' セルに値入力
    Worksheets("シート名一覧").Activate
    Worksheets("シート名一覧").Range("A1").Value = "シート名（現在）"
    Worksheets("シート名一覧").Range("B1").Value = "入力欄" & vbLf & "シート名（変更後）"
    
    Worksheets("シート名一覧").Range("E1").Value = "チェック項目"
    Worksheets("シート名一覧").Range("E2").Value = "重複チェック"
    Worksheets("シート名一覧").Range("E3").Value = "抜け漏れチェック"
    Worksheets("シート名一覧").Range("F1").Value = "シート名一覧"
    Worksheets("シート名一覧").Range("F3").Value = "－"
    Worksheets("シート名一覧").Range("G1").Value = "シート名（変更後）"
    
    For Each ws In Worksheets
        Cells(Selection.row + i, Selection.Column).NumberFormatLocal = "@"
        Cells(Selection.row + i, Selection.Column) = ws.Name
        i = i + 1
    Next
    
    
    ActiveSheet.Name = "シート名一覧"
    
    '変数lastRowにA1セルから見た最下の行数を代入
    lastRow = Worksheets("シート名一覧").Cells(Rows.Count, "A").End(xlUp).row
    
    ' セルに数式入力
    Worksheets("シート名一覧").Range("F2").Value = "=IF(MAX(COUNTIF(A2:A" & lastRow & ",A2:A" & lastRow & "))>1,""有り"",""なし"")"
    Worksheets("シート名一覧").Range("G2").Value = "=IF(MAX(COUNTIF(B2:B" & lastRow & ",B2:B" & lastRow & "))>1,""有り"",""なし"")"
    Worksheets("シート名一覧").Range("G3").Value = "=IF(MIN(COUNTIF(A2:A" & lastRow & ",B2:B" & lastRow & "))=0,""有り"",""なし"")"
    Worksheets("シート名一覧").Range("E5").Value = "エラーチェック"
    Worksheets("シート名一覧").Range("F5").Value = "=IF(F2=""有り"",""エラー"",IF(G2=""有り"",""エラー"",IF(G3=""有り"",""エラー"",""OK"")))"
    Range("F5").Interior.Color = RGB(255, 255, 102) ' 背景色

    ' 書式設定
    Columns("B:B").Select
    Selection.ColumnWidth = 21
    
    Columns("A:G").Select
    Columns("A:G").EntireColumn.AutoFit
    Selection.NumberFormatLocal = "@"
                
    Columns("F:G").Select
    Selection.Replace What:="@", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    
    Columns("A:A").Interior.ColorIndex = 15 ' ライトグレー
    Columns("B:B").Interior.ColorIndex = 36 ' ライトイエロー
    Range("A1").Interior.Color = RGB(102, 152, 255) ' ライトブルー
    Range("B1").Interior.Color = RGB(0, 255, 0) ' グリーン
    Range("E1").Interior.Color = RGB(255, 153, 255) ' ライトピンク
    Range("F1").Interior.Color = RGB(102, 152, 255) ' ライトブルー
    Range("G1").Interior.Color = RGB(0, 255, 0) ' グリーン
    Range("E2:E3").Interior.Color = RGB(255, 204, 255) ' パステルピンク
    Range("E5").Interior.Color = RGB(255, 153, 255) ' ライトピンク
    Range("F3").Interior.ColorIndex = 15 ' ライトグレー
    Range("F5").Interior.ColorIndex = 45 ' イエロー
    
    ' 条件付き書式設定
    Range("F2:G5").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""なし"""

    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 16776960
        .TintAndShade = 0
    End With
    
    Range("F2:G5").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""有り"""

    With Selection.FormatConditions(2).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With
    
    Range("F2:G5").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""OK"""

    With Selection.FormatConditions(3).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 16776960
        .TintAndShade = 0
    End With
    
    ' A1セルを選択
    Range("A1").Select
    
    '画面更新再開
    Application.ScreenUpdating = True
     
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

Sub Aファイルを開く()

Dim OpenFileName As String

OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*")

If OpenFileName = "False" Then

MsgBox "キャンセルされました。処理を終了します。"

End

Else

Workbooks.Open OpenFileName

End If

End Sub

Sub Aシート名取得()

Dim sh As Variant, flag As Boolean

Dim ws As Worksheet

Dim i As Long

i = 0

Call Aファイルを開く

'画面更新停止

Application.ScreenUpdating = False

'確認ダイアログ停止

Application.DisplayAlerts = False

For Each sh In Sheets

If sh.Name = "シート名一覧" Then

flag = True

Exit For

End If

Next sh

If flag = True Then

Dim rc As Integer

'メッセージ表示

rc = MsgBox("シート「シート名一覧」を上書きしますか？" & Chr(13) & "※この処理は戻せません。", vbYesNo + vbQuestion, "確認")

If rc = vbYes Then

'画面更新停止

Application.ScreenUpdating = False

'シート選択

Worksheets("シート名一覧").Activate

'シート削除

ActiveSheet.Delete

'画面更新停止

Application.ScreenUpdating = True

'メッセージ表示

MsgBox "処理前のシート「シート名一覧」は削除済みです。"

Call Aシート名取得2

Else

'メッセージ表示

MsgBox "キャンセルされました。処理を終了します。"

End If

Else

Call Aシート名取得2

End If

'画面更新再開

Application.ScreenUpdating = True

End Sub

Sub Aシート名取得2()

'画面更新停止

Application.ScreenUpdating = False

'シート追加

Worksheets.Add before:=Worksheets(1)

'シート名変更

ActiveSheet.Name = "シート名一覧"

'シート選択

Worksheets("シート名一覧").Activate

' セルに値入力

Worksheets("シート名一覧").Activate

Worksheets("シート名一覧").Range("A1").Value = "シート名（現在）"

Worksheets("シート名一覧").Range("B1").Value = "入力欄" & vbLf & "シート名（変更後）"

Worksheets("シート名一覧").Range("E1").Value = "チェック項目"

Worksheets("シート名一覧").Range("E2").Value = "重複チェック"

Worksheets("シート名一覧").Range("E3").Value = "抜け漏れチェック"

Worksheets("シート名一覧").Range("F1").Value = "シート名一覧"

Worksheets("シート名一覧").Range("F3").Value = "－"

Worksheets("シート名一覧").Range("G1").Value = "シート名（変更後）"

For Each ws In Worksheets

Cells(Selection.row + i, Selection.Column).NumberFormatLocal = "@"

Cells(Selection.row + i, Selection.Column) = ws.Name

i = i + 1

ActiveSheet.Name = "シート名一覧"

'変数lastRowにA1セルから見た最下の行数を代入

lastRow = Worksheets("シート名一覧").Cells(Rows.Count, "A").End(xlUp).row

' セルに数式入力

Worksheets("シート名一覧").Range("F2").Value = "=IF(MAX(COUNTIF(A2:A" & lastRow & ",A2:A" & lastRow & "))>1,""有り"",""なし"")"

Worksheets("シート名一覧").Range("G2").Value = "=IF(MAX(COUNTIF(B2:B" & lastRow & ",B2:B" & lastRow & "))>1,""有り"",""なし"")"

Worksheets("シート名一覧").Range("G3").Value = "=IF(MIN(COUNTIF(A2:A" & lastRow & ",B2:B" & lastRow & "))=0,""有り"",""なし"")"

Worksheets("シート名一覧").Range("E5").Value = "エラーチェック"

Worksheets("シート名一覧").Range("F5").Value = "=IF(F2=""有り"",""エラー"",IF(G2=""有り"",""エラー"",IF(G3=""有り"",""エラー"",""OK"")))"

Range("F5").Interior.Color = RGB(255, 255, 102) ' 背景色

' 書式設定

Columns("B:B").Select

Selection.ColumnWidth = 21

Columns("A:G").Select

Columns("A:G").EntireColumn.AutoFit

Selection.NumberFormatLocal = "@"

Columns("F:G").Select

Selection.Replace What:="@", Replacement:="", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

Columns("A:A").Interior.ColorIndex = 15 ' ライトグレー

Columns("B:B").Interior.ColorIndex = 36 ' ライトイエロー

Range("A1").Interior.Color = RGB(102, 152, 255) ' ライトブルー

Range("B1").Interior.Color = RGB(0, 255, 0) ' グリーン

Range("E1").Interior.Color = RGB(255, 153, 255) ' ライトピンク

Range("F1").Interior.Color = RGB(102, 152, 255) ' ライトブルー

Range("G1").Interior.Color = RGB(0, 255, 0) ' グリーン

Range("E2:E3").Interior.Color = RGB(255, 204, 255) ' パステルピンク

Range("E5").Interior.Color = RGB(255, 153, 255) ' ライトピンク

Range("F3").Interior.ColorIndex = 15 ' ライトグレー

Range("F5").Interior.ColorIndex = 45 ' イエロー

' 条件付き書式設定

Range("F2:G5").Select

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _

Formula1:="=""なし"""

With Selection.FormatConditions(1).Interior

.PatternColorIndex = xlAutomatic

.Color = 16776960

.TintAndShade = 0

End With

Range("F2:G5").Select

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _

Formula1:="=""有り"""

With Selection.FormatConditions(2).Interior

.PatternColorIndex = xlAutomatic

.Color = 65535

.TintAndShade = 0

End With

Range("F2:G5").Select

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _

Formula1:="=""OK"""

With Selection.FormatConditions(3).Interior

.PatternColorIndex = xlAutomatic

.Color = 16776960

.TintAndShade = 0

End With

' A1セルを選択

Range("A1").Select

'画面更新再開

Application.ScreenUpdating = True

End Sub

シートソート

Sub Aシートソート()
    Dim ws As Worksheet
    Dim row, col As Long
    Dim wsNames As Collection
    Dim sh As Variant, flag As Boolean
     
    Set wsNames = New Collection
     
    Call Aファイルを開く
     
    '画面更新停止
    Application.ScreenUpdating = False
     
    '確認ダイアログ停止
    Application.DisplayAlerts = False
     
    For Each sh In Sheets
        If sh.Name = "シート名一覧" And Worksheets("シート名一覧").Range("F5").Value = "OK" Then
        flag = True
    Exit For
     
    ElseIf sh.Name = "シート名一覧" And Worksheets("シート名一覧").Range("F5").Value = "エラー" Then
        MsgBox "エラーがあります。" & Chr(13) & "シート「シート名一覧」で先にエラーを解消して下さい。" & Chr(13) & "処理を終了します。"
        End
    End If
    Next sh
     
    If flag = True Then
     
    Dim ar() As String '// シート名配列
    Dim i As Integer '// ループカウンタ
    Dim s As String '// セル値
     
    Sheets("シート名一覧").Select
    Range("B2").Select
     
    i = 0
    ReDim ar(i)
     
    '// A列をループ
    Do
    '// セルの値を取得
    s = ActiveCell.Offset(i, 0).Value
     
    '// セルが未設定の場合
    If (s = "") Then
    '// ループを抜ける
    Exit Do
    End If
     
    '// 配列を拡張しセル値（シート名）を格納する
    ReDim Preserve ar(i)
    ar(i) = s
     
    i = i + 1
    Loop
     
    '// シートの順序を"AddSheet"の順に並べ替え
    i = 0
    Do
    '// 配列要素がない場合
    If (i > UBound(ar)) Then
    '// ループを抜ける
    Exit Do
    End If
     
    '// 配列の現ループ値のシート名を現ループカウンタ値の右に移動
    Sheets(ar(i)).Move before:=Sheets(i + 1)
     
    i = i + 1
    Loop
     
    '// シート削除の確認ダイアログを表示させてないように指定
    Application.DisplayAlerts = False
     
     
    For Each ws In ActiveWorkbook.Worksheets
        On Error Resume Next
        ws.Name = wsNames.Item(ws.Name)
    Next
     
    Else
     
    'メッセージ表示
    MsgBox "シート「シート名一覧」はありません。" & Chr(13) & "先に「シート名取得」を実行して下さい。" & Chr(13) & "処理を終了します。"
     
    ActiveWindow.Close
     
    End If
     
    '画面更新再開
    Application.ScreenUpdating = True
 
End Sub

Sub Aシートソート()

Dim ws As Worksheet

Dim row, col As Long

Dim wsNames As Collection

Dim sh As Variant, flag As Boolean

Set wsNames = New Collection

Call Aファイルを開く

'画面更新停止

Application.ScreenUpdating = False

'確認ダイアログ停止

Application.DisplayAlerts = False

For Each sh In Sheets

If sh.Name = "シート名一覧" And Worksheets("シート名一覧").Range("F5").Value = "OK" Then

flag = True

Exit For

ElseIf sh.Name = "シート名一覧" And Worksheets("シート名一覧").Range("F5").Value = "エラー" Then

MsgBox "エラーがあります。" & Chr(13) & "シート「シート名一覧」で先にエラーを解消して下さい。" & Chr(13) & "処理を終了します。"

End

End If

Next sh

If flag = True Then

Dim ar() As String '// シート名配列

Dim i As Integer '// ループカウンタ

Dim s As String '// セル値

Sheets("シート名一覧").Select

Range("B2").Select

i = 0

ReDim ar(i)

'// A列をループ

'// セルの値を取得

s = ActiveCell.Offset(i, 0).Value

'// セルが未設定の場合

If (s = "") Then

'// ループを抜ける

Exit Do

End If

'// 配列を拡張しセル値（シート名）を格納する

ReDim Preserve ar(i)

ar(i) = s

i = i + 1

Loop

'// シートの順序を"AddSheet"の順に並べ替え

i = 0

'// 配列要素がない場合

If (i > UBound(ar)) Then

'// ループを抜ける

Exit Do

End If

'// 配列の現ループ値のシート名を現ループカウンタ値の右に移動

Sheets(ar(i)).Move before:=Sheets(i + 1)

i = i + 1

Loop

'// シート削除の確認ダイアログを表示させてないように指定

Application.DisplayAlerts = False

For Each ws In ActiveWorkbook.Worksheets

On Error Resume Next

ws.Name = wsNames.Item(ws.Name)

Else

'メッセージ表示

MsgBox "シート「シート名一覧」はありません。" & Chr(13) & "先に「シート名取得」を実行して下さい。" & Chr(13) & "処理を終了します。"

ActiveWindow.Close

End If

'画面更新再開

Application.ScreenUpdating = True

End Sub

Microsoft Scripting Runtimeを有効にする

Microsoft Scripting Runtimeを有効にする方法が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】Microsoft Scripting Runtimeを有効にする方法

マクロを実行

上記で作成したマクロファイル（ここでは「シートソート.xlsm」とファイル名を設定。）と、
マクロ実行テスト用のダミーデータとして、エクセルファイルを準備します。

※マクロ実行テスト用のダミーデータとして作成した、複数シートを含むエクセルファイル。
シート名、「Sheet1、Sheet2、Sheet3」を含んでいます。

マクロファイルを開いて、「コンテンツの有効化」をクリックします。
※設定により、「コンテンツの有効化」は表示されない（クリック不要の）場合もあります。

「開発」タブをクリックします。

「マクロ」をクリックします。

マクロ「シート名取得」を選択、「実行」をクリックします。

「ファイルを開く」ダイアログが表示されるので、
シートをソートしたい対象エクセルファイルを選択して、「開く」をクリックします。

シート「シート名一覧」が作成されます。

B2セルから下のセルに、希望のシート並び変え順通りに、シート名を入力して、
F5セルの「エラー」から「OK」に変更される様にします。

マクロ「シートソート」を選択、「実行」をクリックします。

「ファイルを開く」ダイアログが表示されるので、
シートをソートしたい対象エクセルファイルを選択して、「開く」をクリックします。

シートの並び順が希望の順番にソートされます。

完了です。

エラーについて

・マクロ「シート名取得」を実行せずにマクロ「シートソート」を実行すると、
シート「シート名一覧」がない為、マクロはエラーになります。
先にマクロ「シート名取得」を実行して下さい。

・シート「シート名一覧」のF5セルが「エラー」の場合、マクロはエラーになります。
A列・B列に重複がないか、B列に漏れがないかをチェックしている為、
先にエラー内容を解消して下さい。

参考サイト

Excel作業をVBAで効率化
VBAでシートを任意の順番で並べ替える｜ Excel作業をVBAで効率化

スキルハンター００７
【エクセルVBA】エクセルのシート名を一括置換するVBA

【エクセルVBA】エクセルのシート名を一括取得するVBA