エクセルファイルの結合

質問

同じフォーマットで作ったファイルが、フォルダに１００件保存されてます。
このファイル１００件（ここでは仮に１００件とさせていただきます。１００件以上の場合もあります）を結合させて、１つのファイルにしたいです。
条件
１．エクセル2010で作ってます。拡張子は「xlsx」です。
２．1つファイルにシートの結合ではありません（100シートは、なし）

手作業でやるとすれば、下記になります。
１．１００個のファイルから、基本となるファイル1つを開きます。
２．開いたファイルの中には、リストがありその末尾を表示させます。
３．次に適当に次のファイルを開きます。
４．リストがある行を全選択して、「切り取り」します。
５．画面を基本ファイルにして、リストの末尾の行を選択して、「貼り付け」します。
６．そしてまた適当なファイルを開いて、同じことを繰り返します。

この作業を９９回やるのは、つらいです。
ただ単純にリストを結合させたいのです。

よろしくお願いします。

回答No.4

HohoPapa · ベストアンサー

対象ファイルは全数拡張子がxlsxで、
>リストがある行を全選択して
これは1枚目のシートで、
A1セルから右下方向に広がり、
リスト範囲の1行目、1列目には空白行が無いという条件でよければ
次のようなコードでいかがでしょうか。

このコードを含むマクロブックは
ファイル群と同じフォルダーに配置して実行してください。

Sub Macro1()

　Dim buf As String
　Dim MyPath As String
　Dim FBook As Workbook
　Dim FSheet As Worksheet
　Dim TSheet As Worksheet
　Dim TRow As Long

　Application.ScreenUpdating = False

　MyPath = ThisWorkbook.Path & "\"
　Set TSheet = ThisWorkbook.Sheets(1)
　TSheet.Cells.Clear
　buf = Dir(MyPath & "*.xlsx")
　　Do While buf <> ""
　　　Set FBook = Workbooks.Open(MyPath & buf)
　　　Set FSheet = FBook.Sheets(1)
　　　If TSheet.Cells(1, 1).Value = "" Then
　　　　TRow = 1
　　　Else
　　　　TRow = TSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　End If
　　　FSheet.Range("A1").CurrentRegion.Copy _
　　　　TSheet.Cells(TRow, 1)
　　　FBook.Close
　　　buf = Dir()
　　Loop

　Application.ScreenUpdating = True

End Sub

お礼

回答ありがとうございます。
ためしてみます

回答No.8

SI299792

自分の事しか考えない人ですね。他の質問には答えてもらっていません。超能力で解れという事ですか。それとも、私の質問の意味が解らなかったでしょうか。仕方がないので、前回同様１行目から結合としました。
　後、フォルダか決まっていない、その都度選択できるようにしたいのなら、最初からそう書いて下さい。書いてないと判りません。
'
Option Explicit
'
Sub Macro1()
'
　　Dim Path As String
　　Dim I As Worksheet
　　Dim FileName As String
　　Dim ROut As Long
　　Dim RCnt As Long
'
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If .Show = True Then
　　　　　　Path = .SelectedItems(1) & "\"
　　　　End If
　　End With
'
　　Set I = ThisWorkbook.ActiveSheet
　　FileName = Dir(Path & "*.xls")
　　ROut = 1
'
　　While FileName > ""
　　　　Workbooks.Open Path & FileName, ReadOnly:=True
　　　　RCnt = Cells(Rows.Count, "A").End(xlUp).Row
　　　　[1:1].Resize(RCnt).Copy I.Cells(ROut, "A").Resize(RCnt)
　　　　ROut = ROut + RCnt
　　　　ActiveWindow.Close False
　　　　FileName = Dir
　　Wend
End Sub

　例えば、図のような表であれば、１、２行目を結合したらまずいわけです。また、Ａ列にデータがないので、データの有無をＢ列で判断する必要があります。だから何行目から、何列から何列までなのか聞きたいのです。（何行目までは決まっていなくていいです）

回答No.7

SI299792

すみません、フォルダは
＞特定しません。
ということは、ダイアログボックスを開いて、フォルダを選択するということでしょうか。
それとも、このマクロを入れたワークブックと同じフォルダでいいのですか。

何行から始まっているのか、これは説明不足でした。
終了行でなく、開始行を聞きたかったのです。（終了行は決まっていないのが普通です）
普通、１行目がタイトルで２行目は項目名なので、３行目から結合させたいとかあります。
それとも、１行目から結合させればいいのですか。

後列、はとこからどこまでですか（前回聞き忘れました）
同じフォーマとなら、Ａ列～Ｚ列など、列は決まっているはずです。

お礼

回答ありがとうございます。
>>ダイアログボックスを開いて、フォルダを選択するということでしょうか
その通りです。

回答No.6

nishi6

この質問で気になるのは、
＞１．１００個のファイルから、基本となるファイル1つを開きます。
次回から開くBookは基本となるBookと異なる必要があります。

＞２．開いたファイルの中には、リストがありその末尾を表示させます。
ファイルを結合するのに、末尾の表示は不要でしょう。

＞４．リストがある行を全選択して、「切り取り」します。
切り取りよりコピーでしょうか。

＞５．画面を基本ファイルにして、リストの末尾の行を選択
貼り付けるのは、末尾+1行でしょう。

一番問題なのはフォーマットが分からないことで、１行目に表題があり、２行目から連続的にデータが入力されているとしました。
また、表題はあるものの、２行目のデータがないと、おかしなことになります。これは、基本となるファイルと２回目以降の処理で発生する可能性があります。一応対応しています。

コードは新規のブックの標準モジュールに貼り付けます。実情に合うように、
　xlsxPath　　Bookがあるフォルダー
　fstBook　　 最初のBook名
　shtName　　 データがあるシート名
　Top = "A1"　データ範囲の左上セル(表題)
をセットしてください。

指定した最初のBook名のBookに結果が表示されます。6Bookでテストしました。ご参考に。当方、win10、Excel2010です。

Sub joinBook()
　Dim wbName As String　　 '// 2つ目以降のデータBook
　Dim ws As Worksheet　　　'// データのあるSheet

　Dim xlsxPath As String　 '// Bookがあるフォルダー
　Dim fstBook As String　　'// 最初のBook名
　Dim shtName As String　　'// データがあるシート名

　Dim Top As String　　　　'// データ範囲の左上セル
　Dim LstRow As Long　　　 '// 最後の行
　Dim maxRow As Long　　　 '// データブックの最大の行

　'// 設定(重要)
　xlsxPath = "N:\履歴\Work_xlsx"
　fstBook = "DataBook000.xlsx"
　shtName = "Sheet1"
　Top = "A1"

　Application.ScreenUpdating = False
　'// 最初のBookを開く
　Workbooks.Open xlsxPath & "\" & fstBook
　Worksheets(shtName).Activate
　LstRow = ActiveSheet.Range(Top).End(xlDown).Row - 1
　　If LstRow + 1 = Rows.Count Then
　　　LstRow = 0
　　End If

　wbName = Dir(xlsxPath & "\" & "*.xlsx")
　While wbName <> ""
　　'// 最初のBookでない
　　If wbName <> fstBook Then
　　　Workbooks.Open xlsxPath & "\" & wbName
　　　Worksheets(shtName).Activate
　　　ActiveSheet.Range(Top).CurrentRegion.Select

　　　'// データがあれば
　　　If Selection.Rows.Count > 1 Then
　　　　Selection.Offset(1, 0).Select
　　　　Selection.Resize(Selection.Rows.Count - 1).Select

　　　　Selection.Copy
　　　　Workbooks(fstBook).Worksheets(shtName).Range(Top).Offset(LstRow + 1, 0).PasteSpecial
　　　　LstRow = LstRow + Selection.Rows.Count
　　　End If

　　　Application.DisplayAlerts = False
　　　Workbooks(wbName).Close
　　　Application.DisplayAlerts = True
　　End If

　　wbName = Dir()
　Wend
　Application.ScreenUpdating = True
End Sub

回答No.5

HohoPapa

#4追記です。

1行目がタイトル行なら以下のようなコードです。

Sub Macro2()

　Dim buf As String
　Dim MyPath As String
　Dim FBook As Workbook
　Dim FSheet As Worksheet
　Dim TSheet As Worksheet
　Dim TRow As Long

　Application.ScreenUpdating = False

　MyPath = ThisWorkbook.Path & "\"
　Set TSheet = ThisWorkbook.Sheets(1)
　TSheet.Cells.Clear
　buf = Dir(MyPath & "*.xlsx")
　　Do While buf <> ""
　　　Set FBook = Workbooks.Open(MyPath & buf)
　　　Set FSheet = FBook.Sheets(1)
　　　If TSheet.Cells(1, 1).Value = "" Then
　　　　TRow = 1
　　　　FSheet.Range("A1").CurrentRegion.Offset(0, 0).Copy _
　　　　　TSheet.Cells(TRow, 1)
　　　Else
　　　　TRow = TSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　FSheet.Range("A1").CurrentRegion.Offset(1, 0).Copy _
　　　　　TSheet.Cells(TRow, 1)
　　　End If
　　　FBook.Close
　　　buf = Dir()
　　Loop

　Application.ScreenUpdating = True

End Sub

お礼

回答ありがとうございます。
ためしてみます

回答No.3

SI299792

もう少し情報が欲しいです。
フォルダはどこか。
何行から始まっているのか、ヘッダーは何行からか。
'
Option Explicit
'
Sub Macro1()
'
　　Const Path = "D:\Test\"
　　Dim I As Worksheet
　　Dim FileName As String
　　Dim RowO As Long
　　Dim RowC As Long
'
　　Set I = ThisWorkbook.ActiveSheet
　　FileName = Dir(Path & "*.xls")
　　RowO = 1
'
　　While FileName > ""
　　　　Workbooks.Open Path & FileName, ReadOnly:=True
　　　　RowC = Cells(Rows.Count, "A").End(xlUp).Row
　　　　[1:1].Resize(RowC).Copy I.Cells(RowO, "A").Resize(RowC)
　　　　RowO = RowO + RowC
　　　　ActiveWindow.Close False
　　　　FileName = Dir
　　Wend
End Sub

とりあえず
フォルダは、D:￥Test￥
Ａ列から全て（XFD 列迄）Ａ列が空白なら動きません。その場合、
赤丸部分を直して下さい。
ヘッダーは無し、データは１行目から、

補足

回答ありがとうございます。
>>フォルダはどこか。
特定しません。デスクトップに作成した「新しいフォルダ」かもしれませんし、サーバーのなかに作成した、名前を付けたフォルダだったり
>>何行から始まっているのか、ヘッダーは何行からか
ファイル内の表の行はまちまちです。５行もあれば500行くらいもあります。
なので、MAX1000行とさせてください。

回答No.2

imogasi

こういうのは操作で用意されているとは質問者も思わないだろう。
だから、VBAを使うことになると思う。
経験ありますか。
ーー
要点は、
各1ファイルにつき１シートだけを問題にするなら簡単です。
（１）問題のフォルダは１つで、ファイルはその中にすべて収まっているなら
　　フォルダの中の各ファイルを捉えるコードを見つけるとよい。
WEBにはコードが載っている記事がたくさんある。
Googleで「VBA　フォルダ内のファイルを開く」」などで検索。
（２）その中のシートは１つだけか？
　　　形だけの空シートや他のデータのシートはないか。　　　
　　　集約するシートが、シートタブ的に一番左に位置すると扱いやすい。いつもSheets(0)で捉えられるから。
（３）A列の最終行が、データリスト列の各最終行と同じなら（凸凹してないなら）簡単に最終行は
Sub test01()
lr = Range("A10000").End(xlUp).Row　　’－－（A）
MsgBox "最終行　" & lr
End Sub
の（A)１行で捉えられる。
（４）データを集約するブックのシートを、あらかじめ決めて、そこに貼りつける。
貼り付けるシートの張り付けるべき（先頭）行は、張り付ける直前に、（A)と同じコードを実行して、それに＋１した行に張り付ければよい。
（５）２つのブックのシートのデータを扱うVBAコードの書き方。
ーー
今までに何度もこの質問は出ていて、コードを書く面白味もなく、テストデータが必要だが作るのは手間とか、コードを書くには時間がかかり、面倒なので略。
そもそもVBAなどをしたことがないのに、この課題を言うのは無理。丸投げになるし、回答のコードの意味も解らないだろうから。
ーー
フリーソフトでもないか探すべきかと。
Googleで「フリーソフト　エクセルシート集約」で照会してみたら、
https://search.vector.co.jp/vsearch/vsearch.php?key=excel+%E3%81%BE%E3%81%A8%E3%82%81%E3%82%8B+%E3%82%B7%E3%83%BC%E3%83%88
似たようなものはあるようだが、ぴったりかどうか、の問題は残る。

回答No.1

kon555

この辺りでどうでしょうか
動作確認はしてませんけども

https://excelkamiwaza.com/folder_file_read.html
https://www.moug.net/tech/exvba/0060003.html
https://www.ex-it-blog.com/Excel-Folder-File-Macro

補足

回答ありがとうございます。
教えていただいたURLは、全てためしましたが、ダメでした。