あのー、Excelのシートをソートする方法ってありますか。
エクセルの標準機能では用意されていませんね。
そうですよねー。シートが10個以上あるんですけど並び変えないといけないんです。めんどうだなー。
では、マクロで解決しましょう！
Excelのシートをソートするマクロをご紹介します。
任意の順番にソート処理可能です。
目次
マクロ機能が有効なExcelブック「.xlsm」を作成
Excelブック「.xlsm」の作成方法が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】マクロ機能が有効なExcelブック「.xlsm」の作り方
コードを標準モジュールに貼り付け
標準モジュールの開き方が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】標準モジュールの開き方
標準モジュールを開いて、下記のコードを貼り付けて下さい。
コード
シート名取得
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 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 |
シートソート
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | 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 |
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
