【VBA】シートを必要数(複数)コピーする

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



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の組合せも可能なので知っておくと活用する場面も多くお薦めです。

◆ファイルの保存

データの書き込み、及びシートを複数コピーしたファイルは読み取り専用で開いているので、名前を付けて保存する必要があります。今回の様なケースの場合は、ファイル名で内容が判断出来るのが望ましいので、「SN 始~終」と設定しています。

F_name = “SN” & Data(2, 1) & “_” & Data(UBound(Data, 1), 1)

保存する際に確認アラートが表示される場合がありますので、Application.DisplayAlertsを使って保存作業を実行する間のみ、非表示としています。

Application.DisplayAlerts = False

Workbooks(bkName).SaveAs Filename:=ThisWorkbook.Path & “\” & F_name & “.xlsx”

Application.DisplayAlerts = True

保存先は同じ場所なのでThisWorkbook.Pathと先程設定したファイル名で保存します。

3.まとめ

シートのコピーや移動自体は特に難しいこともないのですが、必要となる数量を把握して、その分コピーを実行することの方が実運用上は多いと思います。今回はその場合の一例として書いていますが、むしろコピー処理よりもデータ読み書きの処理の方が面倒だったりするなーと書いていて思いました(笑)

コピー自体はSheets(“ワークシート名”).Copy   After:=Sheets(”ワークシート名”)なので、Forなどで処理すれば複数コピーだけでも出来ますから用途に応じて使い分けたら良いと思います。
Microsoft Public Affiliate Program (JP)(マイクロソフトアフィリエイトプログラム)
以上、シートを必要数(複数)コピーする方法についてでした!
今回の記事が何かの参考になれば幸いです。

Ryo

スポンサーリンク
スポンサーリンク

楽天トラベル

シェアする

フォローする

スポンサーリンク

楽天トラベル