複数ファイルからのデータ抽出について

フォルダ内に格納されているExcelファイル(400ファイル)からデータを抽出したいです。

ファイルのsheet2に以下が記載されております。
＜記載＞
A1セル：名前(父)　　B1：年齢　　C1：生年月日　　　D1：住所
A2セル：名前(母)　　B2：年齢　　C2：生年月日　　　D2：住所
※A2～以降も同様ですが、家族の人数によって行数が可変となります。

上記をＶＢＡにて複数ファイルから抽出して1シートに纏めたいです。
＜抽出後＞
またA列には一組目：1、二組目：2と家族番号が知れるように数字を入力したい

A1：1(1家族ごと)　B1セル：名前(A父)　　C1：年齢　　D1：生年月日　　　E1：住所
A2：1(1家族ごと)　B2セル：名前(A母)　　C2：年齢　　D2：生年月日　　　E2：住所
A3：2(1家族ごと)　B3セル：名前(B父)　　C3：年齢　　D3：生年月日　　　E3：住所
A4：2(1家族ごと)　B4セル：名前(B母)　　C4：年齢　　D4：生年月日　　　E4：住所
A5：2(1家族ごと)　B5セル：名前(B弟)　　C5：年齢　　D5：生年月日　　　E5：住所

どなたか上記抽出方法についてご教授いただけますでしょうか。

質問者からの補足コメント

• コメントありがとうございます。
  以下にコメント致します。※先程は誤ったところに記載しておりました。
  
  ①
  元ファイルは1家族1ファイルの認識で問題ございません。
  ファイル内で姓が違っていてもファイル内なので1家族としたいです。
  
  ②
  フォルダ内に他のマクロブックはございません。
  
  ご教授宜しくお願い致します。

  No.3の回答に寄せられた補足コメントです。 補足日時：2019/10/09 08:37

• コメントありがとうございます。
  以下にコメント致します。※先程は誤ったところに記載しておりました。
  
  フォルダ内のファイルは以下で統一されております。
  家族構成_xxxx.xls
  ※xxxxは社員ID
  
  ご教授宜しくお願い致します。

  No.2の回答に寄せられた補足コメントです。 補足日時：2019/10/09 08:38

• コメントありがとうございます。
  
  年齢についても纏め抽出出来ればと思います。
  
  宜しくお願い致します。

  No.4の回答に寄せられた補足コメントです。 補足日時：2019/10/09 09:00

• コメントありがとうございます。
  
  仰る通りIDについてあると助かります。
  ですが一覧で参照した時、A列で何家族か分かりやすくしたいこともあります。
  ※退職職員分のIDが飛んでいたりするので。
  
  確かにコメントいただいたIDについては是非あると助かる、今後活用もう可能ですので
  当該IDはE列に入ってもらうと非常に助かります。
  
  ご確認宜しくお願い致します。

  No.5の回答に寄せられた補足コメントです。 補足日時：2019/10/09 10:52

• 丁寧な回答ありがとうございます。
  
  実行してみたのですがExcel2016を使用しており、『FileSearch』で引っ掛かているようです。
  度々で申し訳ございませんが、ご教授いただければと思います。
  
  宜しくお願い致します。

  No.6の回答に寄せられた補足コメントです。 補足日時：2019/10/09 18:48

• 度々のコメントで申し訳ございません
  ファイル名は『家族構成_xxxx.xls』で問題ございません。
  当該コードを実行すると
  
  「 実行エラー'445'オブジェクトはこの動作をサポートしていません」
  
  となってしまいます。

  No.8の回答に寄せられた補足コメントです。 補足日時：2019/10/09 20:01

• 長々とお付き合いありがとうございます。
  当該コードを実行した結果添付のように想定と異なっております。
  
  実行結果を添付いたします。
  ※想定はあくまでセルをずらして記載しており、スタートはA1からとなります。
  
  大変申し訳ございませんが、ご教授いただけますでしょうか。

  
  No.11の回答に寄せられた補足コメントです。 補足日時：2019/10/09 23:01

• 

  返事が遅くなり大変申し訳ございません。
  
  GooUserラックにいただいたコード、皆さんのご助言のおかげで無事意図する動作と
  なることができました。
  長々と対応いただきほんとに感謝しております。
  
  ありがとうございました。

  No.13の回答に寄せられた補足コメントです。 補足日時：2019/10/10 21:10

No.13 ベストアンサー 回答者： GooUserラック 回答日時： 2019/10/10 08:11

No.11 の改善案です。

改善点① 「社員ID」の部分に数に変換できない文字が有ってもエラーにならないようにしました。
改善点② 「Sheet2」にデータが無い場合はそのファイルをスキップするようにしました。
※ No.12 に対する回答が無いので、根本の対応には成っていないと思います。

Const 纒シート名 As String = "Sheet1" ' 纏めるシート名に変更して下さい。
Dim フォルダー名 As String
Dim ファイル名 As String
Dim コピー先 As Long
Dim 終 As Long
Dim 通番 As Integer

　Sheets(纒シート名).Select
　Cells.ClearContents
　フォルダー名 = ThisWorkbook.Path & "\"
　コピー先 = 1
　ファイル名 = Dir(フォルダー名 & "家族構成_????.xls")
　Do While ファイル名 <> ""
　　Workbooks.Open Filename:=フォルダー名 & ファイル名
　　Sheets("Sheet2").Select
　　If Range("A1").Value <> "" Then
　　　終 = Cells(Rows.Count, 1).End(xlUp).Row
　　　通番 = 通番 + 1
　　　Range(Cells(1, 1), Cells(終, 4)).Copy ThisWorkbook.Worksheets(纒シート名).Cells(コピー先, 2)
　　　ActiveWorkbook.Close False
　　　Range(Cells(コピー先, 1), Cells(コピー先 + 終 - 1, 1)).Value = 通番
　　　Range(Cells(コピー先, 6), Cells(コピー先 + 終 - 1, 6)).Value = Mid(ファイル名, 6, 4)
　　　コピー先 = コピー先 + 終
　　Else
　　　ActiveWorkbook.Close False
　　End If
　　ファイル名 = Dir()
　Loop

End Sub

No.15 回答者： めぐみん_ 回答日時： 2019/10/10 09:34

No.9です。

回答されているコード的には、私は元のデータブックの列が提示されている物とは違うのかな？って感じます。
特にＡ列をチェック欄扱いにしてて例えば同居している人なら”〇”がついているとか。
この場合は確実にその列に最終行までデータのある場所（列）を提示されるのが宜しいかも。

データで歯抜けがあっても１行目と最終行までを範囲としてコピペするので、出来上がりは歯抜けのまま纏まるかと。

しかし火狐では補足がキチンと表示しきれないのは気になる・・・（個人的且つ回答等ではないけど）

この回答へのお礼

的確な意見ありがとうございました。
無事動作することが確認できました。
これを機にちゃんとコードの勉強もしたいと思います。

お礼日時：2019/10/10 21:11

No.14 回答者： tatsu99 回答日時： 2019/10/10 08:24

横からお邪魔します。

あなたのデータ（家族構成_xxxx.xls）のデータですが、
添付図のようにデータが歯抜けになっているケースはありますか。
回答者の方は、このようなケースは想定されていないと思われます。

この回答へのお礼

的確な意見ありがとうございました。
無事動作することが確認できました。
これを機にちゃんとコードの勉強もしたいと思います。

お礼日時：2019/10/10 21:11

No.12 回答者： GooUserラック 回答日時： 2019/10/10 02:18

こちらでは「左記を想定」のようになりましたが、どんな時に「実行結果」のようになるかも考えてみました。

図の左のようなデータの場合は「実行結果」のようになり、図の右のようなデータの場合は「左記を想定」のようになります。
元のデータはどうなっていますか？ご提示ください。

No.11 回答者： GooUserラック 回答日時： 2019/10/09 21:38

No.10 の修正版（不要な処理を省いて変数名を最適化してみました）

Sub Sample()

Const 纒シート名 As String = "Sheet1" ' 纏めるシート名に変更して下さい。
Dim フォルダー名 As String
Dim ファイル名 As String
Dim コピー先 As Long
Dim 終 As Long
Dim 通番 As Integer
Dim 社員ID As Integer

　Sheets(纒シート名).Select
　Cells.ClearContents
　フォルダー名 = ThisWorkbook.Path & "\"
　コピー先 = 1
　ファイル名 = Dir(フォルダー名 & "家族構成_????.xls")
　Do While ファイル名 <> ""
　　通番 = 通番 + 1
　　Workbooks.Open Filename:=フォルダー名 & ファイル名
　　社員ID = Mid(ファイル名, 6, 4)
　　Sheets("Sheet2").Select
　　終 = Cells(Rows.Count, 1).End(xlUp).Row
　　Range(Cells(1, 1), Cells(終, 4)).Copy ThisWorkbook.Worksheets(纒シート名).Cells(コピー先, 2)
　　ActiveWorkbook.Close False
　　Range(Cells(コピー先, 1), Cells(コピー先 + 終 - 1, 1)).Value = 通番
　　Range(Cells(コピー先, 6), Cells(コピー先 + 終 - 1, 6)).Value = 社員ID
　　コピー先 = コピー先 + 終
　　ファイル名 = Dir()
　Loop

End Sub

No.10 回答者： GooUserラック 回答日時： 2019/10/09 21:02

それではこちらではどうでしょうか？

Sub Sample()

Const 纒シート名 As String = "Sheet1" ' 纏めるシート名に変更して下さい。
Dim フォルダー名 As String
Dim ファイル名 As String
Dim フルパス As String
Dim コピー先 As Long
Dim 終 As Long
Dim 通番 As Integer
Dim 社員ID As Integer

　Sheets(纒シート名).Select
　Cells.ClearContents
　フォルダー名 = ThisWorkbook.Path & "\"
　コピー先 = 1
　フルパス = Dir(フォルダー名 & "家族構成_????.xls")
　Do While フルパス <> ""
　　通番 = 通番 + 1
　　Workbooks.Open Filename:=フォルダー名 & フルパス
　　ファイル名 = Right(フルパス, 13)
　　社員ID = Mid(ファイル名, 6, 4)
　　Sheets("Sheet2").Select
　　終 = Cells(Rows.Count, 1).End(xlUp).Row
　　Range(Cells(1, 1), Cells(終, 4)).Copy ThisWorkbook.Worksheets(纒シート名).Cells(コピー先, 2)
　　ActiveWorkbook.Close False
　　Range(Cells(コピー先, 1), Cells(コピー先 + 終 - 1, 1)).Value = 通番
　　Range(Cells(コピー先, 6), Cells(コピー先 + 終 - 1, 6)).Value = 社員ID
　　コピー先 = コピー先 + 終
　　フルパス = Dir()
　Loop

End Sub

No.9 回答者： めぐみん_ 回答日時： 2019/10/09 20:16

No.7です。

更にちょっと疑問。
https://www.google.com/search?client=firefox-b-d …

また使えるようになったのでしょうか？（２０１９が最新でしたっけ？）

エラーは使用しているExcelのバージョンが双方で違うからでは？

この回答へのお礼

めぐみん_様
適切なコメントとありがとうございます。
補足など私でできないことから非常に勉強させていただいております。

補足回数の限度が近いためこちらでのお礼とさせていいただいております。
よろしくお願い致します。

お礼日時：2019/10/09 23:04

No.8 回答者： GooUserラック 回答日時： 2019/10/09 19:14

ファイル名は本当に「家族構成_xxxx.xls」ですか？「家族構成_xxxx.xlsx」ではありませんか？

それでしたら
①「.Filename = "家族構成_????.xls"」⇒「Filename = "家族構成_????.xlsx"」
②「ファイル名 = Right(.FoundFiles(ファイル仮番), 13)」⇒「ファイル名 = Right(.FoundFiles(ファイル仮番), 14)」
にしてみて下さい。

No.7 回答者： めぐみん_ 回答日時： 2019/10/09 12:26

ちょっとした疑問です。

社員ＩＤってどのように付けているのでしょうか？（0012 みたいに先頭に"0"があるとかないとか）
そしてＩＤを有効活用するならＩＤ順に並べた方が良いと言えるのか、気にしないのか。

でしょうかね。
社員ＩＤと言って実際は従業員で”正社員・契約社員・パート・・・”で付け方（頭数字）が変わってるなんてのが昔の会社のシステムではあったもので。

No.6 回答者： GooUserラック 回答日時： 2019/10/09 11:35

それではこんなものはいかがでしょうか？

Sub Sample()

Const 纒シート名 As String = "Sheet1" ' 纏めるシート名に変更して下さい。
Dim フォルダー名 As String
Dim ファイル名 As String
Dim ファイル仮番 As Integer
Dim 社員ID As Integer
Dim 終 As Long
Dim コピー先 As Long
Dim 通番 As Integer

　Sheets(纒シート名).Select ' まとめるシート名に変更して下さい。
　Cells.ClearContents
　コピー先 = 1
　フォルダー名 = ThisWorkbook.Path & "\"
　With Application.FileSearch
　　.LookIn = フォルダー名
　　.Filename = "家族構成_????.xls"
　　If .Execute > 0 Then
　　　For ファイル仮番 = 1 To .FoundFiles.Count
　　　　Workbooks.Open Filename:=.FoundFiles(ファイル仮番)
　　　　ファイル名 = Right(.FoundFiles(ファイル仮番), 13)
　　　　通番 = 通番 + 1
　　　　社員ID = Mid(ファイル名, 6, 4)
　　　　Sheets("Sheet2").Select
　　　　終 = Cells(Rows.Count, 1).End(xlUp).Row
　　　　Range(Cells(1, 1), Cells(終, 4)).Copy ThisWorkbook.Worksheets(纒シート名).Cells(コピー先, 2)
　　　　ActiveWorkbook.Close False
　　　　Range(Cells(コピー先, 1), Cells(コピー先 + 終 - 1, 1)).Value = 通番
　　　　Range(Cells(コピー先, 6), Cells(コピー先 + 終 - 1, 6)).Value = 社員ID
　　　　コピー先 = コピー先 + 終
　　　Next
　　End If
　End With

End Sub