VBA100本ノック 59本目：12ヶ月分のシートを四半期で分割

公開日：2021-01-04　最終更新日：2021-02-22

VBA100本ノック 59本目：12ヶ月分のシートを四半期で分割

1年度12ヶ月分のシートを四半期ごとのブックに分割する問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

#VBA100本ノック 59本目
ブック(ThisWorkbook)には「2020年04月」から「2021年03月」の12シートがあります。
四半期ごとのシートで1ブックとして、同一フォルダに出力ください。
「2020年04月」「2020年05月」「2020年06月」この3シートで→1Q.xlsx
以下同様に4Q.xlsxまでの4ファイル

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_59.xlsm
https://excel-ubara.com/vba100sample/VBA100_59.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

多くの方法があるので、今回はこういう方法もあるという参考VBAです。
複数シートを一括で扱うのは「52本目：複数シートの一括印刷」でやりました。

・出題・頂いた回答・解説・補足・サイト内関連ページ

四半期ごとにシート名を入れる配列を用意して順次入れていきます。
4月からの差があれば除算の整数をとれば四半期の数値になります。


  
    
      Sub VBA100_59_01()

      　　Dim wb As Workbook: Set wb = ThisWorkbook

　　

　　Dim startDt As Date

　　startDt = checkSheets(wb)

　　If startDt = False Then

　　　　MsgBox "シートがおかしい"

　　　　Exit Sub

　　End If

　　

　　Dim i As Long

　　Dim ary(3), quarter As Long

      　　For i = 1 To wb.Sheets.Count

　　　　quarter = DateDiff("m", startDt, CDate(wb.Sheets(i).Name)) \ 3

　　　　If IsEmpty(ary(quarter)) Then

　　　　　　ary(quarter) = Array(wb.Sheets(i).Name)

　　　　Else

　　　　　　ary(quarter) = Split(Join(ary(quarter)) & " " & wb.Sheets(i).Name)

　　　　End If

　　Next

　　

　　Application.DisplayAlerts = False

　　Dim sPath As String

　　sPath = ThisWorkbook.Path & "\"

　　For i = LBound(ary) To UBound(ary)

　　　　wb.Sheets(ary(i)).Copy

　　　　ActiveWorkbook.SaveAs sPath & i + 1 & "Q.xlsx", xlOpenXMLWorkbook

　　　　ActiveWorkbook.Close savechanges:=False

　　Next

　　Application.DisplayAlerts = True

End Sub


  
    
      Function checkSheets(ByVal wb As Workbook) As Variant

　　checkSheets = False

　　

　　If wb.Sheets.Count <> 12 Then

　　　　Exit Function

　　End If

　　

　　Call sortSheets(wb)

　　

　　Dim startDt As Date, endDt As Date, i As Long

　　For i = 1 To wb.Sheets.Count

　　　　If Not IsDate(wb.Sheets(i).Name) Then

　　　　　　Exit Function

      　　　　End If
　　　　If Day(CDate(wb.Sheets(i).Name)) <> 1 Then

　　　　　　Exit Function

　　　　End If

　　　　If startDt = 0 Then

　　　　　　startDt = CDate(wb.Sheets(1).Name)

　　　　　　endDt = DateAdd("m", 11, startDt)

　　　　End If

　　　　If CDate(wb.Sheets(i).Name) > endDt Then

　　　　　　Exit Function

　　　　End If

　　Next

　　

　　checkSheets = startDt

End Function


Sub sortSheets(ByVal wb As Workbook)

　　Dim i As Long, j As Long

　　For i = 12 To 1 Step -1

　　　　For j = 1 To i - 1

　　　　　　If wb.Sheets(j).Name > wb.Sheets(j + 1).Name Then

　　　　　　　　wb.Sheets(j).Move After:=wb.Sheets(j + 1)

　　　　　　End If

　　　　Next

　　Next

End Sub

シートの並べ替えとチェックは出題範囲ではないのですが簡易的に入れてみました。
4月開始かのチェックはあえて入れませんでした。
シートの並べ替えは「15本目：シートの並べ替え」でやりましたね。

・出題・頂いた回答・解説・補足・サイト内関連ページ

VBAは記事に掲載しました。補足はありません。

補足

補足はありません。

サイト内関連ページ

第46回．VBA関数（日付,DateAdd）｜VBA入門

・日付時刻に関するVBA関数の一覧・DateAdd関数の構文・DateAdd関数の使用例

第66回．シートのコピー・移動・削除Copy,Move,Delete）｜VBA入門

・シートのコピー・移動・シートの削除・シートのコピー・移動・削除の関連記事

IsDate関数｜VBA関数

・IsDate関数・IsDate関数の使用例・Is○○関数一覧

CDate関数｜VBA関数

・CDate関数・CDate関数の使用例・日付型 (Date)について・データ型変換関数一覧

DateDiff関数｜VBA関数

DateDiff関数は、2つの指定した日付の時間間隔を表す値を返します。ワークシート関数のDATEDIF関数とはスペルも引数も違います、さらに、年の計算は違ったものとなっていますので注意してください。DateDiff関数 DateDiff(interval,date1,date2[,firstdayofweek[,

同じテーマ「VBA100本ノック」の記事

56本目：数式内の自身のシート名を消す

・出題・頂いた回答・解説・補足・サイト内関連ページ

57本目：ファイルの更新日時

・出題・頂いた回答・解説・補足・サイト内関連ページ

58本目：番号リストを簡潔にした文字列で返す

・出題・頂いた回答・解説・補足・サイト内関連ページ

59本目：12ヶ月分のシートを四半期で分割
60本目：「株式会社」の表記ゆれ置換

・出題・頂いた回答・解説・補足・サイト内関連ページ

61本目：「ふりがな」の取得と設定

・出題・頂いた回答・解説・補足・サイト内関連ページ

62本目：独自のZLOOKUP関数を作成

・出題・頂いた回答・解説・補足・サイト内関連ページ

63本目：複数シートの連結

・出題・頂いた回答・解説・補足・サイト内関連ページ

64本目：リンクされた図（カメラ機能）

・出題・頂いた回答・解説・補足・サイト内関連ページ

65本目：固定長テキスト出力

・出題・頂いた回答・解説・補足・サイト内関連ページ

66本目：全サブフォルダからファイルを探す

・出題・頂いた回答・解説・補足・サイト内関連ページ

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.メッセージボックス(MsgBox関数)｜VBA入門
8.セルのクリア（Clear,ClearContents）｜VBA入門
9.ブック・シートの選択（Select,Activate）｜VBA入門
10.条件分岐（Select Case）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
59本目：12ヶ月分のシートを四半期で分割

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック 59本目：12ヶ月分のシートを四半期で分割