[Excel VBA] 複数のシートを操作する

複数のシートを操作するVBAを作成します。

参考・引用元記事： 日経ソフトウェア 2019年9月号 「ビジネスパーソンの Excel VBA 再入門 第4回 複数のシートを操作しよう」

1. 作業日により、月ごとにシートを分割する

[概要]

作業日により、月ごとにシートを分割するVBAマクロを作成します。

下記が使用するサンプルデータです。
このデータを「作業日」の月ごとに別のシートへ分離します。

「月分割」という名称のマクロを実行します。

実行結果の例です。「2月分」「3月分」「4月分」というシートを生成してそれぞれのシートへ対応するデータのコピーが行われました。

[プログラムソース "sample.xlsm" - Module1]

'
' "一覧"シートから作業日を確認して、作業日が2月、3月、4月、のものを"2月分"、"3月分"、"4月分"のシートへコピーする
'
Sub 月分割()
    Dim i
       
    For i = 2 To 4                                                                                            ' --- (1)
        ' 2月から4月でフィルタ
        Worksheets("一覧").Range("A2").AutoFilter field:=3, Criteria1:=i + 20, Operator:=xlFilterDynamic      ' --- (2)
        
        Worksheets.Add after:=Worksheets(Worksheets.Count)                                                    ' --- (3)
        ActiveSheet.Name = i & "月分"                                                                         ' --- (4)
        Worksheets("一覧").UsedRange.Copy                                                                     ' --- (5)
        
        With Worksheets(i & "月分").Range("A1")                                                               ' --- (6)
            .PasteSpecial xlPasteColumnWidths                                                                 ' --- (7)
            .PasteSpecial xlPasteAll                                                                          ' --- (8)
        End With
    Next i
    
    With Worksheets("一覧")
        .Select
        .ShowAllData                                                                                          ' --- (9))
    End With
End Sub

(1) For ・・・ Next ステートメントは、カウンタ変数 i の開始値が「2」、終了値が「4」に指定されています。したがって i の値が「2→3→4」と3回繰り返し処理を実行します。

(2) AutoFilter メソッドを使用して「一覧」シートのA2セルから始まる表をオートフィルターします。
フィルター条件として、C列（field:=3）の値が 22～24 のデータ（Criteria1:=i+20）を抽出します。また「Operator:=xlFilterDynamic」とすることで、フィルターが同的に適用されるように指定しています。これは「日付フィルター」の「期間内の全日付」で、2月～4月の指定をしたのと同じになります。Criteria1には、定数を使用して指定を行いますが、定数ではなく値を指定することで繰り返し処理で利用することができます。全日付を指定する定数は以下の通りです。

表：日付フィルターの条件として指定可能な定数と値

上記指定の方法以外に、下記のような具体的な日付を指定する方法もあります。
こちらの方法を使うと、異なる年で同じ月、という条件を排除できます。

Sub 月分割()
    Dim i, date1, date2
       
    For i = 2 To 4
        date1 = DateSerial(2019, i, 1)                  ' 例えば date1="2019/2/1" のとき...
        date2 = DateAdd("m", 1, date1)                  ' date2 は "2019/3/1" になって...
        date2 = DateAdd("d", -1, date2)                 ' ここで date2 が "2019/2/28" になります。
                                                        ' 閏年 を考慮した場合もよい実装と思います。

        Worksheets("一覧").Range("A2").AutoFilter field:=3, Criteria1:=">=" & date1, Criteria2:="<=" & date2, Operator:=xlAnd
        
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = i & "月分"
        Worksheets("一覧").UsedRange.Copy
        
        With Worksheets(i & "月分").Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll
        End With
    Next i
    
    With Worksheets("一覧")
        .Select
        .ShowAllData
    End With
End Sub

(3) Worksheets コレクションへ新しいシートを挿入（Add）します。
挿入場所は、一番右にあるワークシート（Worksheets(Worksheets.Count)）の右側（After）です。

(4) アクティブシートの名前を「i & "月分"」に変更します。新しいシートを挿入すると、そのシートが必ずアクティブシートになります。結果として「2月分」、「3月分」、「4月分」という名称でシートが挿入されることになります。

(5) 「一覧」シートの使用されているセル範囲（UsedRange）をコピーします。UsedRange プロパティは、ワークシートで使用されているセル範囲を参照します。この例では、絞り込まれている各月のデータになります。

(6) With ステートメントは、この後「EndWith」が記載されるまでの間、「.（ピリオド）」で始まる個所を「Worksheets(i & "月分").Range("A1")」に対する命令として指定します。また、Worksheets("〇〇〇")と、文字列でシート名を指定することで、特定のシートを操作の対象にすることができます。

(7) 各列の列幅（xlPasteColumn）を張り付け（PasteSpecial）ます。

(8) その他のすべて（xlPasteAll）を張り付け（PasteSpecial）ます。

(9) 「一覧」シートの絞り込みを解除（.ShowAllData）してコードを終了します。

2. "一覧"以外のシートをすべて削除する

[概要]

[プログラムソース "sample.xlsm" - Module1]

'
' シート名 "一覧" 以外のシートを削除する
'
Sub シート削除()
    Dim sht
    
    Application.DisplayAlerts = False
    
    For Each sht In Worksheets
        If sht.Name <> "一覧" Then
            sht.Delete
        End If
    Next sht
End Sub

3. ”シート一覧” シートを作成する

[概要]

4. 全ソースコード

[プログラムソース "sample.xlsm" - 標準モジュール（Module1）全体]

'
' "一覧"シートから作業日を確認して、作業日が2月、3月、4月、のものを"2月分"、"3月分"、"4月分"のシートへコピーする
'
Sub 月分割()
    Dim i
       
    For i = 2 To 4
        ' 2月から4月でフィルタ
        Worksheets("一覧").Range("A2").AutoFilter field:=3, Criteria1:=i + 20, Operator:=xlFilterDynamic
        
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = i & "月分"
        Worksheets("一覧").UsedRange.Copy
        
        With Worksheets(i & "月分").Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll
        End With
    Next i
    
    With Worksheets("一覧")
        .Select
        .ShowAllData
    End With
End Sub


'
' シート名 "2月分"、"3月分"、"4月分" の３つのシートを削除する
'
Sub シート削除()
    Dim sht
    
    Application.DisplayAlerts = False
    
    For Each sht In Worksheets
        If sht.Name <> "一覧" Then
            sht.Delete
        End If
    Next sht
End Sub


'
' "シート一覧" を作成する
'
Sub シート一覧()
    Dim i
    
    Application.DisplayAlerts = False
    
    ' もし "シート一覧" シートがあったら削除
    If IsExistSheet_Object("シート一覧") = True Then
        ' "シート一覧" シートがあるので削除
        Worksheets("シート一覧").Delete
    End If
    
    Worksheets.Add before:=Worksheets(1)
    ActiveSheet.Name = "シート一覧"
    
    With Worksheets("シート一覧")
        .Cells(1, "A") = "番号"
        .Cells(1, "B") = "シート名"
        
        For i = 1 To Worksheets.Count
            .Cells(i + 1, "A") = i
            .Cells(i + 1, "B") = Worksheets(i).Name
            .Hyperlinks.Add anchor:=.Cells(i + 1, "B"), Address:="", SubAddress:=Worksheets(i).Name & "!A1"
        Next i
        
        .Columns.AutoFit
        .Range(.Cells(1, "A"), .Cells(1, "B")).Interior.ColorIndex = 15
        .UsedRange.Borders.LineStyle = xlContinuous
        
    End With
    
End Sub


'
' "指定したシート名" のシートの有無を確認する
' True   : ある
' False  : ない
'
'Public Function IsExistSheet_Object(checkBookNm As String, checkSheetNm As String) As Boolean
Public Function IsExistSheet_Object(checkSheetNm As String) As Boolean
 
    Dim targetSheet As Worksheet    '対象シートをセットする変数
    Dim ret         As Boolean      'チェック結果
    
    'エラー無視
    On Error Resume Next
    
    'オブジェクト変数に、対象シートをセットする
    'Set targetSheet = Workbooks(checkBookNm).Worksheets(checkSheetNm)
    Set targetSheet = Worksheets(checkSheetNm)
    
    'エラー無視を解除
    On Error GoTo 0
    
    'オブジェクト変数に、シートがセットされているかどうかで存在を判定
    If targetSheet Is Nothing Then
        ret = False
    Else
        ret = True
    End If
 
    '存在チェックの結果を返す
    IsExistSheet_Object = ret
    
End Function

サンプルプログラム

サンプルプログラム ダウンロード

参考

• 日経ソフトウェア 2019年9月号 「ビジネスパーソンの Excel VBA 再入門 第4回 複数のシートを操作しよう」