Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。
100本ノックの出題リストはこちらから
excel-ubara.com
出題:12ヶ月分のシートを四半期で分割
#VBA100本ノック 59本目
ブック(ThisWorkbook)には「2020年04月」から「2021年03月」の12シートがあります。
四半期ごとのシートで1ブックとして、同一フォルダに出力ください。
「2020年04月」「2020年05月」「2020年06月」この3シートで→1Q.xlsx
以下同様に4Q.xlsxまでの4ファイル


◇ 出題ページはこちら
ソースコード
Option Explicit ' 100本ノック059:12ヶ月分のシートを四半期で分割 Sub 四半期別ファイルを出力する() ' 年・Qをループ Dim 対象年 As Long For 対象年 = 2000 To 2100 Dim 対象Q As Long For 対象Q = 1 To 4 ' 対象3シートの名称を配列にセット Dim Arrシート名リスト Select Case 対象Q Case 1 To 3 Dim 対象月 As Long: 対象月 = 対象Q * 3 + 1 Arrシート名リスト = Array(対象年 & "年" & Format(対象月, "00") & "月" _ , 対象年 & "年" & Format(対象月 + 1, "00") & "月" _ , 対象年 & "年" & Format(対象月 + 2, "00") & "月") Case 4 Arrシート名リスト = Array(対象年 + 1 & "年01月" _ , 対象年 + 1 & "年02月" _ , 対象年 + 1 & "年03月") End Select ' 3シートそろっているQへ出力処理 On Error Resume Next Dim 四半期シート群 As Sheets: Set 四半期シート群 = Nothing Set 四半期シート群 = ThisWorkbook.Worksheets(Arrシート名リスト) On Error GoTo 0 If Not 四半期シート群 Is Nothing Then 四半期シート群.Copy Dim wb出力ブック As Workbook: Set wb出力ブック = ActiveWorkbook Dim Path出力フォルダ As String Path出力フォルダ = ThisWorkbook.Path & "\" & 対象年 & "年" MkDir Path出力フォルダ wb出力ブック.SaveAs Path出力フォルダ & "\" & 対象Q & "Q.xlsx" wb出力ブック.Close False End If Next Next End Sub
解説
ブック内のシートを3つずつ別のブックに出力する問題です。
どこまでを自動対応するか自由度の高い問題ですが、
今回は「全年・四半期で3シートそろっているものを出力」という仕様にしました。
複数シートを一括で行う場合は、シート名の配列を作って
Worksheets(Array("Sheet1", "Sheet2", "Sheet3"))
この形に持っていければよいです。
シート名の配列を作る部分は年と年度の違いに気を付ける必要があり、
1~3月は対象の年度とシート名にズレが生じます。
この判定を綺麗に計算式にしようとしても難読化するだけですし、
所詮4種類の分岐ですので、解答のように1~3月だけベタ打ちして問題ありません。
年度対応はSelect Caseで愚直に書いた方が読みやすいことも多いので、
Modを複雑に使った無駄にエレガントな数式を組まないように気を付けましょう。