フォルダ内のファイルを読み込んでデータを１つにまとめるマクロ（vba）

☆１つずつファイルを開けてコピー＆ペーストは大変です

　フォルダにエクセルファイルが多数あり、その中の一つひとつを読み込んで
　一つのエクセルファイルにまとめる場合があります。
　手作業でもできますが、マクロでできると便利です。
　データを集めるファイルは（Answer.xlsx）としていますが、細かいところは
　適宜改造してお使い下さい。

☆このマクロでできること

（例）
　マクロを実行する Excelファイルのフォルダ　c:\temp
　データを集める新規の Excelファイル　　　　c:\temp\Answer.xlsx
　集めたいデータが入っているフォルダ　　　　c:\temp\data

　データフォルダに次の3つのExcelファイルがあり、

　　　Sample1.xlsx の　A1:あ,　B1:い
　　　Sample2.xlsx の　A1:う,　B1:え
　　　Sample3.xlsx の　A1:お,　B1:か

　が入っていて　c:\temp\Answer.xlsxにファイル名とデータをまとめる場合は次のようになります。

　　　

　データが入っているファイルの
　コピー元のワークシート名や範囲は、
　マクロの中の
　★シートを指定する場合　★コピー元の指定
　で直接指定できす。

　集めたいデータが入っているセルの範囲を変更する場合は「A1:B1」の部分を書きかえてください。

☆使い方

Excelを起動し、メニューバーの「開発」から「Visual Basic」を起動して
左の方にある「VBAProject」のツリーの一つ下の
「Microsoft Excel Objects」を右クリックして
「挿入」→「標準モジュール」で、新しいマクロエディタが開きます。
下に掲載したコードをそこにコピー＆ペーストして、実行して下さい

データが入っているフォルダを選ぶダイアログが表示されるようになっています。

☆コード（各ファイルのA1:B1のデータを集める場合）


Sub DataSyukei()
'
    Dim myPath As String, myBook As String
    Dim Answer As Workbook
    Dim myAnswerLocate As String   'Answer.xlsxの保存フォルダ
    Dim xlLastRow As Long          'Excel自体の最終行
    Dim LastRow As Long            '最終行
    
    Dim wsActive As Worksheet
       
    Application.ScreenUpdating = False  '画面の書き換えをOFF

    'データのパスをダイアログから取得
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        myPath = .SelectedItems(1) & "\"
    End With
    
    'データのパスのファイルを取得
    myBook = Dir(myPath & "*.xlsx")
    
    '現在のフォルダのAnswer.xlsxに出力
    myAnswerLocate = ThisWorkbook.Path & "\Answer.xlsx"


    Do Until myBook = ""        'ファイル名が取得できる間繰り返す
    
        Workbooks.Open myPath & myBook
        
        '★シートを指定する場合「'」を削除し、シート名を変更して下さい
        'Sheets("データがはいているシート").Select
        
        '★コピー元の指定（A1セルからB1セルまでをコピーする場合）
        Range("A1:B1").Select
        Selection.Copy
                        
        '集計先のファイル名 Workbook型の変数で受けると開くことができる
        'マクロを実行するファイルのフォルダにAnswer.xlsxという結果を回収するファイルを準備)
        Set Answer = Workbooks.Open(myAnswerLocate)
       
        xlLastRow = Cells(Rows.Count, 1).Row          'Excelの最終行
        LastRow = Cells(xlLastRow, 2).End(xlUp).Row   '列の最終行を取得
        
        Windows("Answer.xlsx").Activate
 
        Cells(LastRow + 1, 2).Value = myBook        'ファイル名を2列目に入力
        Cells(LastRow + 1, 3).Select                '3列目を選択
    
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Application.CutCopyMode = False             'クリップボードダイアログOFF
        
        Workbooks(myBook).Close SaveChanges:=True   '保存して閉じる
        Answer.Close SaveChanges:=True              '出力ファイルを一度保存して閉じる
            

        myBook = Dir                                '次のファイル名を取得
        
    Loop
    
    
    'クリップボードダイアログ　ON
    Application.CutCopyMode = True
    
    '画面の書き換えを元に戻す
    Application.ScreenUpdating = True
    
    'Answer.xlsx　を開いて終了する
    Set Answer = Workbooks.Open(myAnswerLocate)
    
End Sub

☆参考（各ファイルの一つのセルの値を取得する場合）


Sub data_gather()
    Dim myPath As String, myBook As String
    Dim Answer As Workbook
    
    Dim xlLastRow As Long       'Excel自体の最終行
    Dim LastRow As Long         '最終行
    
    Dim atai As Long            '取得するセルが数値の場合

    Application.ScreenUpdating = False  '画面の書き換えをOFF

    myPath = "c:\temp\data\"            'データファイルのパスをここで指定
    myBook = Dir(myPath & "*.xlsx")
    
    
    Do Until myBook = ""        'ファイル名が取得できる間繰り返す
    
        Workbooks.Open myPath & myBook
        atai = Range("A1").Value                    'A1にある数値を集める場合
        Workbooks(myBook).Close SaveChanges:=True   '保存して閉じる
        
        Set Answer = Workbooks.Open("C:\temp\Answer.xlsx")  '集計するファイル名
        
        xlLastRow = Cells(Rows.Count, 1).Row  'Excelの最終行
        LastRow = Cells(xlLastRow, 2).End(xlUp).Row   'D列の最終行を取得
        
        Cells(LastRow + 1, 2).Value = myBook    'ファイル名を2列目に入力
        Cells(LastRow + 1, 3).Value = atai      '値(atai)　を3列目に入力
        
        Answer.Close SaveChanges:=True          '出力ファイルを一度保存して閉じる
        
        myBook = Dir                            '次のファイル名を取得
        
    Loop
    
    Application.ScreenUpdating = True   '画面の書き換えを元に戻す

    'Answer.xlsx　を開いて終了する
    Set Answer = Workbooks.Open("C:\temp\Answer.xlsx")  '(C:\temp\にAnswer.xlsxという結果を回収するファイルを準備)
    
End Sub

☆参考文献

(1) EXCELマクロ＆VBAプロ技セレクション　技術評論社

←戻る