【Excel VBA】特定文字を含む複数シートの表をコピーしてまとめてみる

マクロを使って複数シートの表をまとめてみたくなったので、

マクロを使って複数シートの表をまとめてみました。

前回記事

ソースコードは前回からの継ぎ足しです。

VBAでやりたいこと

・指定したキーワードを含むシート名の中にある表をすべて取得する

・↑この処理を、複数ファイルに対して同様に行う

・処理画面をいちいち表示させず、高速に処理を行う

状況設定

場所　C:\work\vba

inフォルダ：読み取りたいエクセルファイルがあるフォルダ

outフォルダ：書き込みたいエクセルファイル(out.xlsx)を出力するフォルダ

test3.xlsm：マクロを実行するエクセルファイル

inフォルダ内にはファイルが複数存在しています。

これらをすべて読み込みたいです。

読み込みたいファイルの中身はこちら↑

同一フォーマットで、同じような表がシートごとに存在します。

表のあるシート名は、必ず『表●●』です。該当のシートのみを全て選択し、うまく表を抜き出したいです。

入力フォルダ、出力フォルダはエクセルのシート上で指定させます。

出力はout.xlsxの名前で新規作成して保存します。

実装

'複数ファイルの読み込み→別ファイルに書き込み
Sub csvmerge()
  'Excelの画面を非表示に
  Application.ScreenUpdating = False

  '変数宣言
  Dim InFilename As String
  
  Dim Book_in As Workbook    'ブック(入力)
  Dim Book_out As Workbook   'ブック(出力)
  
  Dim Sheet_in As Worksheet
  
  Dim Path_in As String     'フォルダパス(入力)
  Dim Path_out As String    'フォルダパス(出力)
  
  Dim PX As Long   '座標(貼り付け位置)
  
  Dim xlLastRow As Long       'Excel自体の最終行
  Dim StartRow As Long        '開始行
  Dim LastRow As Long         '最終行
  
  'フォルダのパスを取得
  Path_in = range("F4")
  Path_out = range("F7")
  
  InFilename = Dir(Path_in & "\*.xlsx")
  
  '入力ファイルの開始行
  StartRow = 5
  
  '出力ファイルを新規作成して変数に格納
  Set Book_out = Workbooks.Add
  Book_out.SaveAs Filename:=Path_out & "¥" & "out.xlsx"
  
  '出力ファイルの出力開始位置
  PX = 2
  
  '入力ファイルの数だけループ
  Do While InFilename <> ""
    '入力ファイルを開いて変数に格納
    Workbooks.Open Path_in & "¥" & InFilename
    Set Book_in = ActiveWorkbook
    
    'シートの数だけループ
    For Each Sheet_in In Worksheets
      'シート名頭に『表』が含まれる場合
      If Sheet_in.Name Like "表*" Then
        '/*********************************** 表コピー処理 ***************************************************/
        '入力ファイルの最終行を取得
        xlLastRow = Book_in.Worksheets(Sheet_in.Name).Cells(Rows.Count, 1).Row  'Excelの最終行を取得
        LastRow = Book_in.Worksheets(Sheet_in.Name).Cells(xlLastRow, 2).End(xlUp).Row   'B列の最終行を取得
  
        '入力ファイルをコピーして出力ファイルに張り付け
        Book_in.Worksheets(Sheet_in.Name).Rows(StartRow & ":" & LastRow).Copy Book_out.Worksheets("Sheet1").Rows(PX)
    
        '次の出力ファイルの書き込み位置を調整
        PX = PX + LastRow - StartRow
        
        '/*******************************************************************************************************/
      End If
    Next
    
    'ブックを閉じる
    Book_in.Close
     
    'まだ選んでないフォルダ内のファイルを選択
    InFilename = Dir()
  Loop
  
  'ブックを保存
  Book_out.Save
  
  'ブックを閉じる
  Book_out.Close

End Sub

'複数ファイルの読み込み→別ファイルに書き込み

Sub csvmerge()

'Excelの画面を非表示に

Application.ScreenUpdating = False

'変数宣言

Dim InFilename As String

Dim Book_in As Workbook 'ブック(入力)

Dim Book_out As Workbook 'ブック(出力)

Dim Sheet_in As Worksheet

Dim Path_in As String 'フォルダパス(入力)

Dim Path_out As String 'フォルダパス(出力)

Dim PX As Long '座標(貼り付け位置)

Dim xlLastRow As Long 'Excel自体の最終行

Dim StartRow As Long '開始行

Dim LastRow As Long '最終行

'フォルダのパスを取得

Path_in = range("F4")

Path_out = range("F7")

InFilename = Dir(Path_in & "\*.xlsx")

'入力ファイルの開始行

StartRow = 5

'出力ファイルを新規作成して変数に格納

Set Book_out = Workbooks.Add

Book_out.SaveAs Filename:=Path_out & "¥" & "out.xlsx"

'出力ファイルの出力開始位置

PX = 2

'入力ファイルの数だけループ

Do While InFilename <> ""

'入力ファイルを開いて変数に格納

Workbooks.Open Path_in & "¥" & InFilename

Set Book_in = ActiveWorkbook

'シートの数だけループ

For Each Sheet_in In Worksheets

'シート名頭に『表』が含まれる場合

If Sheet_in.Name Like "表*" Then

'/*********************************** 表コピー処理 ***************************************************/

'入力ファイルの最終行を取得

xlLastRow = Book_in.Worksheets(Sheet_in.Name).Cells(Rows.Count, 1).Row 'Excelの最終行を取得

LastRow = Book_in.Worksheets(Sheet_in.Name).Cells(xlLastRow, 2).End(xlUp).Row 'B列の最終行を取得

'入力ファイルをコピーして出力ファイルに張り付け

Book_in.Worksheets(Sheet_in.Name).Rows(StartRow & ":" & LastRow).Copy Book_out.Worksheets("Sheet1").Rows(PX)

'次の出力ファイルの書き込み位置を調整

PX = PX + LastRow - StartRow

'/*******************************************************************************************************/

End If

'ブックを閉じる

Book_in.Close

'まだ選んでないフォルダ内のファイルを選択

InFilename = Dir()

Loop

'ブックを保存

Book_out.Save

'ブックを閉じる

Book_out.Close

End Sub

①指定したキーワードを含むシート名の中にある表をすべて取得する

 'シートの数だけループ
    For Each Sheet_in In Worksheets
      'シート名頭に『表』が含まれる場合
      If Sheet_in.Name Like "表*" Then
        '/*********************************** 表コピー処理 ***************************************************/
         略
        '/*******************************************************************************************************/
      End If
    Next

'シートの数だけループ

For Each Sheet_in In Worksheets

'シート名頭に『表』が含まれる場合

If Sheet_in.Name Like "表*" Then

'/*********************************** 表コピー処理 ***************************************************/

略

'/*******************************************************************************************************/

End If

ファイル内にあるシートの数だけループします。

変数Sheet_in にシート情報が毎回格納。

Sheet_in.Name でシート名を取得出来ます。

あとはLikeを使った条件分岐を行い、正のときのみコピー処理を行うようにしました。

②1の処理を複数ファイルに対して行う

これは前回記事で紹介しました。

③処理画面をいちいち表示させず、高速に処理を行う

頭に1行追加するだけです。

'Excelの画面を非表示に
  Application.ScreenUpdating = False

1 2	'Excelの画面を非表示に Application.ScreenUpdating = False

結果

出力はこのようになりました。

複数ファイル、複数シートの表が一つにまとまりました。

まつよう

とりあえず満足です