投稿日:

同じフォルダ内の複数ブックデータ統合

～続・VBA～

こんばんは！そして、あけましておめでとうございます！（本日１月１５日・・ｗ）

本年もどうぞよろしくお願い致します(*´ｰ`*)

さて、昨年年末から今年年明けまでバタバタと忙しくしておりまして久々の更新です。

昨年１１月頃から、仕事で行う集計の為にエクセルVBAのお勉強をしております。

仕事の空いた時間で「同じフォルダ内の複数ブックを統合するマクロ」に件数チェック機能をつけるというミッションをいただいておりまして。解決する為日々試行錯誤しております（笑）

VBA面白いですね。

取り扱う データの量がかなり多いので、この「統合する」という作業が省けるだけでも結構時間の節約になるんです。。

という訳で、自分の為の備忘録＋「 同じフォルダ内の複数ブックを統合するマクロ 」を仕事で使いたいという方への情報共有の為にブログに記しておきます。

「始めてVBAをいじるよ。」という方は下の手順でデフォルトでは隠れている「開発タブ」を表示させておいてください。

開発タブを表示してVBAを書く手順

  1. 「ファイル」タブ－「オプション」をクリック
  2. 「リボンのユーザー設定」をクリック
  3. 画面右の「リボンのユーザー設定」配下に表示されるタブ一覧で「開発」にチェックを入れる
  4. 画面上部の開発タブクリック⇒visualbasicをクリック
  5. 標準モジュールに下の「sub~」を張り付ける

※標準モジュールの追加方法はこちらのサイトでとても分かりやすくまとめられていますのでこちらをご覧ください：）（officeTANAKAさん、ありがとうございます！）

http://officetanaka.net/excel/vba/beginner/10.htm

以下貼り付け

Sub ブック集計()

    '集計シートを変数に格納
    Dim ws As Worksheet
    Set ws = ActiveSheet

    '集計シートを全て削除しておく
    ws.Cells.Clear
    
    '集計シートの最終行を取得しておく
    Dim LastRow As Long
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
            
            
    'メッセージ
    MsgBox "このブックと同じフォルダにあるブックを全て統合します"
            
            
'---ファイルを開く前に、場所とファイル名の一覧を取得しておく
    
    'このブックの保存されているフォルダのパス（番地;ディレクトリ）を変数に取得
    Dim thisPath As String
    thisPath = ThisWorkbook.Path
        
    
    'ディレクトリにあるExcelのファイル名を取得(Dir関数)
    '("*.xlsx"(ワイルドカード)でExcelブックだけを指定)
    Dim fileName As String
    fileName = Dir(thisPath & "\" & "*.xlsx")
    
        
    '画面のちらつきを防止する（※処理が終わったらTrueに戻す）
    Application.ScreenUpdating = False
    
    
    
'---ループで順番にファイルを開いてデータを取り込む
        
    'ループカウンタ変数
    Dim i As Long
    
    
    'ファイル名が無くなるまで繰り返す
    Do While fileName <> ""
        
        '開くワークブックを変数に代入
        Dim bufBook As Workbook
        Set bufBook = Workbooks.Open(thisPath & "\" & fileName)  '(ディレクトリ\ファイル名) となる
        
        
        '開いたブックの第1シートの全データ --> 集計シートの最終行
        bufBook.Worksheets(1).Range("A1").CurrentRegion.Copy Destination:=ws.Range("A" & LastRow)
    
        
        '最初のループ以外では、タイトル行を削除しておく
        If i > 0 Then
            ws.Rows(LastRow).Delete
        End If
        
        '開いたブックを閉じる
        bufBook.Close SaveChanges:=False    'False:「保存しますか?」を強制的に「いいえ」
                
        '集計シートの最終行を再取得しておく
        LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        
        
        ' Dir関数は引数を省略すると、直前に取得したファイル名を飛ばして
        'まだ返していないファイル名を順に返す。→次のファイル名が取り出される。
        fileName = Dir()
        
        i = i + 1

    Loop
    
    '画面のちらつき防止措置を終了
    Application.ScreenUpdating = True

End Sub

↑ここまで

はい。 では今日はこの辺りで！

何かの役に立てば嬉しいです(*´ｰ`*)

ご覧いただきありがとうございました！

おやすみなさい！