複数のファイルをひとつにまとめる方法について

Question

お世話になっております。

表題の件、大学の課題のため、以下のマクロを作りたいと考えています。

Aファイル→10行目から20行目までデータがある

Bファイル→10行目から40行目までデータがある

Cファイル→10行目から100行目までデータがある

(A,B,C共にすべてEXCELファイルです)

作りたいファイル→各ファイルの10行目からデータのあるすべての行をコピーし、下に貼り付けたファイル

作りたいファイルのイメージ

Aファイル
Aファイル10行目　10行目のすべてのデータ
 ・
 ・
 ・
 ・
Aファイル20行目　20行目のすべてのデータ

Bファイル
Bファイル10行目　10行目のすべてのデータ
 ・
 ・
 ・
 ・
Bファイル40行目　40行目のすべてのデータ

Cファイル
Cファイル10行目　10行目のすべてのデータ
 ・
 ・
 ・
 ・
Cファイル100行目　100行目のすべてのデータ

結合ファイル
結合ファイル10行目　Aファイルの10行目のすべてのデータ
 ・
 ・
 ・
 ・
結合ファイル20行目　Aファイルの20行目のすべてのデータ
結合ファイル21行目　Bファイルの10行目のすべてのデータ
 ・
 ・
 ・
 ・
結合ファイル61行目　Bファイルの40行目のすべてのデータ
結合ファイル62行目　Cファイルの10行目のすべてのデータ
 ・
 ・
 ・
 ・
結合ファイル152行目 Cファイルの100行目のすべてのデータ

実際の課題はファイル数が90以上になることが予想され、コピーするデータが膨大なものになります。

コピーアンドペーストでは時間がかかることが予想されミスも予想されるため、ファイルをひとつにまとめてコピーアンドペーストできるマクロの方法がないか、お知恵をお貸しいただければと思います。

もしご不明点等ありましたらお知らせください。

以上、お手数ですが、よろしくお願いします。

Answer 1

単にデータをまとめたいというだけなら Excel ブックではなく各ファイルのデーターを csv に書き出して、type か copy で連結すれば終わりですが。

---

hebikuzure

Answer 2

すごくベタなコードですけど、その分わかりやすいかと…

前提として、次の3つがありますが、適宜修正してください。

1.統合結果ブックの１行目にタイトルを作成しておく（このブックの標準モジュール）
2.結合したい各ブックは、１つのフォルダーに入れておく
3.結合したい各ブックのコピー範囲は１行目にはタイトルがあるとして、レコード数-１
　↓
タイトルがなければ、その分修正してください。

メインプロシージャ ：任意フォルダのBookを統合
CALLプロシージャ　：範囲指定とコピー、統合貼り付け

'**************************************************************
' フォルダを選択し、新しいシートに統合
'　ブック名：統合 シート名：統合　★1行目にタイトルあり
'**************************************************************
Sub 任意フォルダのBookを統合()

    Dim fld As FileDialog
    Dim fd_path As String
    Dim fl_name As String
    Dim fd_name As String
    Dim book As String
    Dim i As Long
     
     '「ファイルを開く」ダイアログボックスでフォルダーを指定
     Set fld = Application.FileDialog(msoFileDialogFolderPicker)
     'キャンセル時にマクロ終了
     If fld.Show = 0 Then Exit Sub
     'フォルダのフルパスを変数に格納
     fd_path = fld.SelectedItems(1)
     '指定されたフォルダ名を取得(Dir関数の第2引数）
     fd_name = Dir(fd_path, vbDirectory)
     '指定されたフォルダの一つ目のファイル名を取得
     fl_name = Dir(fd_path & "\*")
     If fl_name = "" Then MsgBox "ファイルが存在しません。": Exit Sub
        
     i = 0
     ChDir fd_path & "\"  'カレントフォルダの変更
    
     Do Until fl_name = ""
       book = fd_path & "\" & fl_name
      
            Workbooks.Open Filename:=book
            Sheets(1).Select
            Call 範囲指定とコピー
           '貼り付け先
            Windows("統合.xlsx").Activate
            Sheets("統合").Select
            Call 統合貼り付け
          
            Windows(fl_name).Activate
            ActiveWorkbook.Close
      
       i = i + 1
       fl_name = Dir  '次のファイル名を取得
     Loop
     MsgBox "統合終了"
End Sub
'********************************************
Sub 範囲指定とコピー()
'1行目に項目名があるデータリストで、項目行をはずして選択

    Dim cntRow As Long
    Dim cntCol As Long
    Dim Rng As Range
   
    Set Rng = ActiveSheet.Range("A1").CurrentRegion
   
    cntRow = Rng.Rows.Count - 1
    cntCol = Rng.Columns.Count
   
    Set Rng = Rng.Offset(1, 0)              '※1行下にずらす
    Set Rng = Rng.Resize(cntRow, cntCol)    '※1行削る
   
    Rng.Copy
   
End Sub
'************************
Sub 統合貼り付け()

    Range("A1").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

End Sub

'************************

以上です。

YumiCat

Answer 3

コピー元のデータが対象セル領域内に全て収まっていて領域内で空白セルなどがないこと、
領域外にデータがない状態かつ、テキストデータのみでいい場合は以下のような方法は
どうでしょうか。
(以下の方法では書式もコピーできない)

コピー元ファイルが A.xlsx, B.xlsx, C.xlsx でマクロブックと同じフォルダにあること、
データの始まりが A10 からであることを前提としています。

Sub 連結()
    Dim f As Variant
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim rng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' コピー先のブックを作る
    Set wb = Workbooks.Add
    Set sh = wb.ActiveSheet

    For Each f In Array("A", "B", "C")
        ' ブックを開く
        With Workbooks.Open(ThisWorkbook.Path & "\" & f & ".xlsx", , True)
            ' 利用されているセル領域を取得
            Set rng = .ActiveSheet.Range("a10").CurrentRegion
            ' コピー先のブックをアクティブにする
            wb.Activate
            ' 値のコピー
            sh.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
            .Saved = True
            ' 閉じる
            .Close
        End With
    Next

    ' 余分な先頭行を削除
    sh.Range("a1").EntireRow.Delete

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub