【VBA】シートを必要数（複数）コピーする

こんにちは、Ryoです。
VBAでワークシート処理を行う際に、用途によっては複数コピーを実行したいこともあるかと思います。今回はサンプルとして読み込んだデータに対し、別ファイルの「DataSheet」を開いて書込みとデータ数分のシートをコピーしていく方法について書いてみたいと思います。

1.サンプル概要
2.サンプルコード
3.まとめ

1.サンプル概要

先ずS/N（シリアルNo.)1000～1030までのデータが書かれたファイルがあるとします。

このデータは「S/N毎」に「DataSheet」を作成する必要がある為、原紙データを読み取り専用で開き、必要データ書込み～シートコピーを必要数分実行後、ファイル名を変更し保存を実行するものです。

このように各S/N毎に1Sheet 作成、書込み、Sheet名変更を行い、順次Sheetを追加（コピー）していくサンプルとなります。

2.サンプルコード

Sub Sample1()

  Dim S_Str As Variant
  Dim Data() As Variant
  Dim LastRow, LastCol As Long
  Dim i, j, R_Cnt, C_Cnt As Integer
  Dim bkName, F_name As String
  
  '画面固定化
  Application.ScreenUpdating = False
  
  '文字検索し最終行と最終列を取得、範囲指定し配列に格納
  For Each S_Str In ActiveSheet.UsedRange
    If S_Str = "S/N" Then
        '最終列
        LastCol = Cells(S_Str.Row, Columns.Count).End(xlToLeft).Column
        '最終行
        LastRow = Cells(Rows.Count, S_Str.Column).End(xlUp).Row
        '範囲指定しDataへ格納
        Data = Range(Cells(S_Str.Row, S_Str.Column), Cells(LastRow, LastCol))
    End If
  Next
  
  '配列の1次要素数取得
  R_Cnt = UBound(Data, 1) - 1
  '配列の2次要素数取得
  C_Cnt = UBound(Data, 2)
  
  'データを書込むファイル名を設定
  bkName = "DataSheetSample.xlsx"
  '本サンプルでは同じ保存先にあるファイルを読取り専用で開く
  Workbooks.Open Filename:=ThisWorkbook.Path & "\" & bkName, ReadOnly:=True
  
  '配列1次要素数分繰り返し（データ数）
  For i = 1 To R_Cnt
    'シート名をSerial No.に変更する
    ActiveSheet.Name = "Serial No." & Data(i + 1, 1)
    
      '文字検索し必要データの書込み
      For Each S_Str In ActiveSheet.UsedRange
          Select Case S_Str
             Case Is = "Serial No."
               S_Str.Select
               For j = 1 To C_Cnt
                 ActiveCell.Offset(1, j - 1) = Data(i + 1, j)
                 ActiveCell.Offset(1, j - 1).Font.Size = 15
               Next j
          End Select
       Next
      
      'データ書き込み後、ワークシートのコピーを行う
       If i <> R_Cnt Then
         Sheets("Serial No." & Data(i + 1, 1)).Copy _
         After:=Sheets(Sheets.Count)
         'コピー後不要なデータはクリアしておく
         Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 5)).ClearContents
       End If
    Next i
    
    'ファイル名はS/Nの「始」～「終」とし、名前を付けて保存を実行
    F_name = "SN" & Data(2, 1) & "_" & Data(UBound(Data, 1), 1)
    
    Application.DisplayAlerts = False
    Workbooks(bkName).SaveAs Filename:=ThisWorkbook.Path & "\" & F_name & ".xlsx"
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
    
End Sub

◆データ読み込み

本サンプルは概要で示した「元データ」ファイルと「DataSheet」ファイルがあり、同じ保存場所にあることを前提としています。

先ずは元データのファイルから読み込むので、文字列検索にFor Eachを使っています。
「S/N」を探すのは、表内の左上に位置するので基点にしやすい為なので、ここは用途に応じて変わってくる部分かと思います。

文字検索後、入力された最終行と最終列を取得することで表全体の範囲が指定できますから、配列にその範囲を指定して格納します。

後は配列に格納した1次要素数、2次要素数を取得しておき、ループ処理に備えておきます。

◆データ書き込み

書込み用ファイルを読取り専用で開き、先程取得した配列の1次要素数、2次要素数を使ってループ処理を行います。（ファイル名：DataSheetSample.xlsx)

その際にSheet名もActiveSheet.Name = “Serial No.” & Data(i + 1, 1)の部分で変更させていますが、ここは複数シートに跨って処理をする場合にSheet名をわかりやすくしておくのは必須だと思います。

後は同様に基点になる文字列を検索し、データの書き込みを行います。

◆ワークシートのコピー

コピーはSheets(“Serial No.” & Data(i + 1, 1)).Copy After:=Sheets(Sheets.Count)の部分で実行しています。この中で重要なのはSheets(Sheets.Count)とすることで、シート最後尾（右端）に追加されていきますので、覚えておくと便利です。

後はコピーを実行することで不要な入力済みデータが発生する為、クリアしています。
コピー実行後も実行前に選択されていたセルがアクティブになっているので、
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 5)).ClearContentsのように範囲を指定してクリアしますが、この通りRangeとOffsetの組合せも可能なので知っておくと活用する場面も多くお薦めです。