ExcelVBAにて、同じフォルダ内における複数ブックの特定項目（名前、住所）の集計

ExcelVBAにて、同じフォルダ内における複数ブックの特定項目（名前、住所）の集計しようと考えて、以下のように作成しましたが、シートの一行目しか取得できません。２行目以降も取得したいのですが、やり方についてご存じの方がいたら、ご教示ください。

'ボタンをクリックした時の処理
Public Sub sample()

Dim wFile As String
Dim wFilePath As String
Dim i As Long

'Excelファイルが存在していたらファイル名を返す
wFile = Dir(ActiveWorkbook.Path & "\*.xlsx")

'先頭行を指定
i = 2

'カレントディレクトリに存在するExcelファイルを全て読み込む
Do While wFile <> ""

'開くExcelファイルのフルパスを取得
wFilePath = ActiveWorkbook.Path & "\" & wFile

'名前・住所を取得し配列に格納する（区切り文字：|）
strData = Split(File_Load(wFilePath), "|")

'名前
Cells(i, 1) = strData(0)

'住所
Cells(i, 2) = strData(1)

'ファイル名
Cells(i, 3) = wFile

'次のExcelファイルを取得
wFile = Dir()

'行数をカウント
i = i + 1

Loop

End Sub

'Excelファイルを開いてデータを取得
'戻り値：名前|住所　（ | で区切る）
Function File_Load(ByVal wFilePath As String) As String

Dim CurBookName As Variant
Dim ColNo As Long
Dim RowNo As Long
Dim strValue As String
Dim FoundCell As Range
Dim i As Long


'ファイルを開く
Workbooks.Open wFilePath

'開いたExcelのファイル名を取得
CurBookName = Application.ActiveWorkbook.Name

'検索する項目を配列に格納
wItem = Array("名前", "住所")

Dim s As Long



'検索する
For i = LBound(wItem) To UBound(wItem)
Set FoundCell = Cells.Find(What:=wItem(i))
If FoundCell Is Nothing Then
'検索出来なかった場合
If i = 0 Then
strValue = ""
Else
strValue = strValue & "|"
End If
Else
'検索したセルに移動
FoundCell.Select
ColNo = ActiveCell.Column '列番号を取得
RowNo = ActiveCell.Row '行番号を取得
'住所を取得する
If i = 0 Then
'最初の項目
strValue = Cells(RowNo + 1, ColNo).Value
Else
'2番目以降の項目は|で区切る
strValue = strValue & "|" & Cells(RowNo + 1, ColNo).Value
End If
End If
Next i

'結果を返す
File_Load = strValue

'開いたExcelファイルを閉じる
Application.DisplayAlerts = False '確認メッセージの非表示
Workbooks(CurBookName).Close
Application.DisplayAlerts = True '確認メッセージの表示

End Function

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

• 

  申し訳ありません。
  各ブックのシート１の名前、住所を一覧ブックに集計するのは、上記のマクロで問題なく処理できたのですが、また上から新たなものを作成して欲しいと依頼があり、困っております。
  今度は、集計する項目が、受付日、氏名、郵便番号、住所、電話番号、金額、用途、入金日、公表名、公表金額、納入方法、個数、品物と増えたうえ、各ブックのシート１だけではなく、全てのシートに項目がちらばっているため、全てのシートから集計するようにしなければなりません。
  種々試しているのですが、私のスキルが未熟すぎてうまくいきません。
  お忙しいところ、大変恐縮ですが、またご指導、ご鞭撻いただければ幸いでございます。

  No.4の回答に寄せられた補足コメントです。 補足日時：2020/02/14 19:07

• ご丁寧にありがとうございます。
  別の用事で、会社から出てしまっておりますので再度確認して連絡いたします。

  No.10の回答に寄せられた補足コメントです。 補足日時：2020/02/14 20:06

No.11 回答者： めぐみん_ 回答日時： 2020/02/14 21:14

すいませんが、あとは常連さんにお任せする事になりそうです。

No.9の方法では１つのブックで複数のシートに対してやるにもそのシート名を取得し処理するってのはややこしそうですので、普通にブックを開いてやった方が良いでしょうね。

確か２０１３でしたね。
２０１６以降ならパワークエリでいけたかもですが、ここは仕方ないですよね。

でも今回課題を解決できたなら今後もドンドン指示されそうですね。
私個人はそれが嫌なのであくまで自分の業務でしか使わず・見せずでした。
仮に解決できるにしてもそんな評価はいらないって事と後々めんどくさいって理由で。

この回答へのお礼

返事遅れて申し訳ありません。
種々ご指摘いただきありがとうございました。

お礼日時：2020/02/24 15:16

No.10 回答者： GooUserラック 回答日時： 2020/02/14 19:42

「各ブックのシート１だけではなく、全てのシートに項目がちらばっているため」とは、次のうちどれでしょうか？

① それぞれのシートに全ての項目が存在するものだけを集計する
② たとえば「シート1」には、｢受付日｣｢氏名｣｢郵便番号｣｢住所｣｢電話番号｣、「シート2」には、｢氏名｣｢金額｣｢用途｣｢入金日｣｢公表名｣｢公表金額｣｢納入方法｣｢個数｣｢品物｣のように分散されていてキーになる物が有りそれが同じ物は同じデータとして扱う。
　⇒ キーとなる項目（例では「氏名」）は何ですか？（例のように「氏名」をキーにした場合に同姓同名がいたら成り立ちません）
③ たとえば「シート1」には、｢受付日｣｢氏名｣｢郵便番号｣｢住所｣｢電話番号｣、「シート2」には、｢金額｣｢用途｣｢入金日｣｢公表名｣｢公表金額｣｢納入方法｣｢個数｣｢品物｣のように分散されていてキーになる物は無く同じ行の物は同じデータとして扱う。（行削除や行挿入されるとデータとして成り立たないのであまりやらないと思います）
④ その他（具体的に説明して下さい）

この回答へのお礼

返事遅れて申し訳ありません。
委託事業者と協議し、転記するデータは、一つのシートにまとめてもらうことになりました。
種々ご提案いただき誠にありがとうございます。
質問が締め切りになってしまいましたので、また改めて質問させていただきます。

お礼日時：2020/02/24 15:39

No.9 回答者： めぐみん_ 回答日時： 2020/02/12 23:46

色々書いててまともに回答もしてないので一案。

ただしＯＳとOfficeのBit数が違うとするとどうなるのかは経験がないです。
XP(32Bit)+Excel2002(32Bit)
10(64Bit)+Excel 365(64Bit)
なら経験してます。

あとAccessがインストールされてないと無理かも知れませんけど。
一応『Microsoft Access データベース エンジン 2010 再頒布可能コンポーネント』と言うのを入れれば可能性があるのですが、
先のＯＳとOfficeのBit数が違った場合の対処法については未経験です。
動かなかったらごめんなさい。

Sub megu()
Dim objCn As Object '★参照設定なし版
Dim objRS As Object '★参照設定なし版
Dim r1 As Range
Dim strSQL As String
Dim f_Path As String, f_Name As String

Set objCn = CreateObject("ADODB.Connection") '★参照設定なし版
Set objRS = CreateObject("ADODB.Recordset") '★参照設定なし版
f_Path = ThisWorkbook.Path & "\"

With Worksheets("Sheet1") '★纏めるＢｏｏｋのシート
If .Range("A1").Value = "" Then _
.Range("A1:C1").Value = Array("名前", "住所", "ブック名")

Set r1 = .Cells(Rows.Count, "A").End(xlUp).Offset(1)
End With

strSQL = ""
strSQL = strSQL & " SELECT 名前 , 住所" '★１行目は必ず項目名がある事。存在する場所（列）や順序等には左右されない
strSQL = strSQL & " FROM [Sheet1$]" '★それぞれのシート名が同じである事に注意！

f_Name = Dir(f_Path & "*.xlsx")

Do Until f_Name = ""

With objCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=YES;"
.Open f_Path & f_Name
End With

objRS.Open strSQL, objCn, 1 '★ 1 : adOpenKeyset がないと参照設定なしの場合レコード数が取れない

r1.Offset(, 2).Resize(objRS.RecordCount).Value = f_Name
r1.CopyFromRecordset objRS

Set r1 = r1.Offset(objRS.RecordCount)

objRS.Close
objCn.Close

f_Name = Dir()
Loop

Set r1 = Nothing
Set objCn = Nothing
Set objRS = Nothing
End Sub

この回答へのお礼

ご回答ありがとうございます。

お礼日時：2020/02/24 15:17

No.8 回答者： めぐみん_ 回答日時： 2020/02/11 09:21

日付って点でいくと『複数の業者』にばら撒いている事から、ファイルの更新日での順序なのかなって考えちゃいましたね。

簡単にいけば『登録した当日の日付』とも思ったのですが、特に返信もないので動きようもなく・・・
他のサイト等で解決したのかな？

この回答へのお礼

めぐみんさん、素人同然の私に的確なアドバイスをまことにありがとうございます。
ご指摘のとおり、私もファイルの更新日での順序も候補して考えておりましたが、ブック名の前の数字や日付で管理したほうが他の職員にもわかりやすいかなと考えたため、当内容で順序を管理するとした次第でございます。
素人同然の私の考えたことなのでお許しください。

なお、他の方からも、いくつかアドバイスをいただておりますので、作成向けて現在　再チャレンジしているところです。

お礼日時：2020/02/11 15:07

No.7 回答者： Qchan1962 回答日時： 2020/02/10 22:16

こんばんは、

すでに、他のやり方、回答はあるようですが、、
Do While wFile <> ""
strData = Split(File_Load(wFilePath), "|")　これは、ファイルのDoで一回しか呼ばれないかと思いますが、
なので書き出しまでを繰り返す必要があります。その場合、File_Loadの引数も変える必要があるかと。
Do（For） データが無くなるまで（データがある範囲）
strData = Split(File_Load(ブック、シート、行、列などの情報), "|")　’ほとんどFunctionぽく無くなりそう。
Cells(i, 1) = strData(0)'名前
Cells(i, 2) = strData(1)'住所
Cells(i, 3) = wFile'ファイル名
Next

Function File_Load　側　
もし、1ファイル1回の呼び出しの場合は、

For i = LBound(wItem) To UBound(wItem)・・・？
これ、wItem = Array("名前", "住所")　なので LBound(wItem)＝？　UBound(wItem)＝？
そうです。0と１ですね。すると、
'2番目以降の項目は|で区切る
strValue = strValue & "|" & Cells(RowNo + 1, ColNo).Value
のコード何回通りますか？
やはり、データの（この場合対象シート行数の）ある数だけ繰り返す必要がありますね。

また、Set FoundCell = Cells.Find(What:=wItem(i))
これは、シート全体を検索しています。
1行目が見出し行であるなら、、Range(Cells(1, 1),Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column)).Find(wItem(i)).Column
まあまあ、、範囲が未定なら良いですが、、

例えば、
Dim Maxrow As Long

ColNo = ActiveCell.Column '列番号を取得
RowNo = ActiveCell.Row '行番号を取得
Maxrow = ActiveSheet.Cells(Rows.Count, ColNo).End(xlUp).Row
　　 For j = RowNo+1 to Maxrow '見出し行の下から（RowNoが見出し行とした場合）
　　　'住所を取得する
　　　’If j = 1 Then　上で見出し行の下からなので要らない
　　　'最初の項目
　　　’strValue = Cells(RowNo + 1, ColNo).Value
　　　’Else
　　　'2番目以降の項目は|で区切る
　　　　　strValue = strValue & "|" & Cells(j, ColNo).Value　’strValueの初めに空文字が入らない工夫を、、又は最後に左一文字を消す？
　　　’End If
　　Next j
　End If
Next i
しかし、Splitすると困ったことにこれだとstrData(0)....strData(20)...みたいに増えますね。
また、Cells(i, 1) = strData(0)'名前　Cells(i, 2) = strData(1)'住所　Cells(i, 3) = wFile'ファイル名　が出力となると
ColNo = ActiveCell.Column '列番号を取得部分を増やす必要がありますね。
（Function File_Loadの渡す前にwItem = Array("名前", "住所")で配列ループが必要かな）
いっそのこと、strData()を配列にしてstrData(j,ColNo)=strValue strData(j,ColNo1)=strValue1 strData(j,ColNo2)=strValue2　みたいに、、
なんとなく、、直して使えそうですが、、、やってられない感出てきました。。

先の事を考えると、ロジックを検討する余地がありそうですが、、事情もお在りかと。。
＃４GooUserラックさんの回答にあるように、Copyを使えるならその方がExcelらしいと言うか、簡単ですよ。
処理的な問題があるなら、仕方ありませんが。。

時間があったので、当たり前の事に纏めず、あ～だこうだと長文を書いてみました。
下記は、お詫びを兼ねて。

ファイルの処理順、、について、
strData = Split(File_Load(wFilePath), "|")のような使い方でファイルの昇順（タイムスタンプ）のソートを作ったので参考にする機会があれば、、、です。

４，５列にそれぞれ書き出すので、新規のシートか何かで試してみてください。
ファイルを順次　処理ルーチンに投げれば、昇順タイムスタンプでファイルが処理できます。
タイムスタンプ取得部分をファイル名にすれば、ファイル名の昇順で実行できるかと思います。

Sub fileSort()
Dim f As Object, i As Long, j As Long
Dim ArrFile() As String, tmp As Variant
Dim FName As String
　　'----------フォルダ内ファイル抽出（配列作成）
　　With CreateObject("Scripting.FileSystemObject")
　　　　For Each f In .GetFolder(ThisWorkbook.Path).Files　　'ThisWorkbook.Pathフォルダパス
　　　　　　If LCase(.GetExtensionName(f)) = "xlsx" _
　　　　　　Or LCase(.GetExtensionName(f)) = "xlsm" Then
　　　　　　　　i = i + 1
　　　　　　　　ReDim Preserve ArrFile(i)
　　　　　　　　ArrFile(i) = f.DateCreated & "|" & f.Name　'昇順ファイル名なら入れ替える
　　　　　　End If
　　　　Next f
　　End With
　　For i = 1 To UBound(ArrFile)
　　　　For j = UBound(ArrFile) To i Step -1
　　　　　　If ArrFile(i) > ArrFile(j) Then
　　　　　　　　tmp = ArrFile(i)
　　　　　　　　ArrFile(i) = ArrFile(j)
　　　　　　　　ArrFile(j) = tmp
　　　　　　End If
　　　　Next j
　　Next i
　　tmp = ""
　　For i = 1 To UBound(ArrFile)
　　　　tmp = Split(ArrFile(i), "|")
　　　　　　Cells(i, 4) = tmp(1)　　　　　 '昇順タイムスタンプ (ファイル名)
　　　　　　Cells(i, 5) = tmp(0)　　　　　 ' (タイムスタンプ)
　　'　　　　FName = tmp(1)
　　'　　　　Call Sample1(FName)
　　Next
End Sub

最後まで読んで頂いたなら、時間を使い申し訳ありませんでした。^;

この回答へのお礼

本当にありがとうございます。
参考にさせていただきます。
また、わかりにく質問で大変お手数をおかけしました。
お許しください。

お礼日時：2020/02/11 14:46

No.6 回答者： めぐみん_ 回答日時： 2020/02/10 09:51

＞③のせる順番は、前に日付か番号をつけ、その順序。

まずデータを取得するＢｏｏｋの順序も気にはなりますが、『前に日付か順番をつけ、その順序』の『前』って何を差しているのでしょう？
ブック名の事？
取り込んだデータに日付かインデックスを付ける？
こう言った場合なら求める結果の例題を載せて貰えるとわかりやすいのかと。

この回答へのお礼

めぐみんさん、種々のご指摘ありがとうございます。
ご指摘のとおり、私の質問の仕方が悪いです。
前⇒同じフォルダ内にあるブック名の名前の前に日付か順番をつけるという意味でございました。

お礼日時：2020/02/11 14:53

No.5 回答者： めぐみん_ 回答日時： 2020/02/10 06:49

お礼を拝見しましたが、各ブックのシートにあるデータが１行目から始まってるのなら、

『名前・住所』の項目を検索するのは不可能です

仮に１行目に項目があるけどそれぞれがどの列にあるのか不明と言うのなら、
複数の業者となってましたので名称を変えられてる可能性はないのでしょうか？

個人的には項目名に変更がなければ、どこにあるのか？と探すのも面倒なので、
ADO等を使ってブックに接続し取り出すデータ群を指定して抽出しますね
ただ2013は不所持（Bitも不明）なので書いてもそちらで動く保証はないです

この回答へのお礼

各ブックのシート　見出しがあるので２行目となりまね。
数々のご指摘ありがとうございます。

お礼日時：2020/02/11 14:48

No.4 回答者： GooUserラック 回答日時： 2020/02/10 01:05

それでしたら以下のような物はいかがですか？

Sub Sample()

Dim ファイル名 As String
Dim シート番号 As Long
Dim 列番号 As Long
Dim 名前列 As Long
Dim 住所列 As Long
Dim 一覧行 As Long
Dim 終 As Long

　一覧行 = Cells(Rows.Count, 1).End(xlUp).Row + 1
　ファイル名 = Dir(ThisWorkbook.Path & "\*.xlsx")
　Do While ファイル名 <> ""
　　Workbooks.Open Filename:=ThisWorkbook.Path & "\" & ファイル名
　　　Sheets(1).Select
　　　名前列 = 0
　　　住所列 = 0
　　　For 列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　　　If Cells(1, 列番号).Value = "名前" Then 名前列 = 列番号
　　　　If Cells(1, 列番号).Value = "住所" Then 住所列 = 列番号
　　　Next
　　　If 名前列 <> 0 Then
　　　　If 住所列 <> 0 Then
　　　　　終 = Cells(Rows.Count, 名前列).End(xlUp).Row
　　　　　Range(Cells(2, 名前列), Cells(終, 名前列)).Copy
　　　　　Windows("一覧.xlsm").Activate
　　　　　Cells(一覧行, 1).Select
　　　　　ActiveSheet.Paste
　　　　　Windows(ファイル名).Activate
　　　　　Range(Cells(2, 住所列), Cells(終, 住所列)).Copy
　　　　　Windows("一覧.xlsm").Activate
　　　　　Cells(一覧行, 2).Select
　　　　　ActiveSheet.Paste
　　　　　Range(Cells(一覧行, 3), Cells(一覧行 + 終 - 2, 3)).Value = ファイル名
　　　　　一覧行 = 一覧行 + 終 - 1
　　　　　Windows(ファイル名).Activate
　　　　End If
　　　End If
　　Application.CutCopyMode = False
　　ActiveWindow.Close
　　ファイル名 = Dir()
　Loop

End Sub

この回答へのお礼

ご助言ありがとうございます。
お忙しいところ恐縮です。
勉強になります。

お礼日時：2020/02/11 14:43

No.3 回答者： GooUserラック 回答日時： 2020/02/09 18:31

念のため確認させていただきます。

①「一覧.xlsm」と同じフォルダにある「○○○.xlsx」の「名前」と「住所」の列データとその「ファイル名」を「一覧.xlsm」にまとめるだけのような感じですが間違いありませんか？
② 重複データはどうするのでしょうか？
　ⓐ そのまま全て載せる
　ⓑ どれか１つだけ載せる
　ⓒ その他（具体的に説明して下さい）
③ 載せる順番になにかルールはありますか？
④ 実行ごとに１度データはクリアした方が良いですか？
　ⓓ 毎回クリアする
　ⓔ クリアせず追加していく
　ⓕ その他（具体的に説明して下さい）
⑤ シートに関して
　ⓖ 一番左のシートのみ処理する
　ⓗ「○○○.xlsx」は全てのシートから１行目に「名前」と「住所」が有る物を使う
　ⓘ その他（具体的に説明して下さい）
⑥ Excel のバージョンは何ですか？

この回答へのお礼

大変わかりにくくて申し訳ありません。
最終的には、集計用の一覧.xlsx(xlsm)ブックに集計ボタンを置いて、それをクリックすると各ブック（名前.住所 １．xlsx,名前 住所 ２ xlsx）のシート１のデータが、一覧.xlsx(xlsm)ブックに転記されるようにしたいのです。
添付画像でいうと、名前.住所 １．xlsx シート１から、１行目 氏名 岡島 博・住所 東京都、２行目 山田 隆・堺市を転記するようにしたいのですが、一行目の氏名 岡島 博・住所 東京都しか上記のVBAでは転記されません。なお、岡田 敦 大阪狭山市は、名前 住所 ２ xlsx シート１の一行目となります。
なお、名前.住所 ．xlsxのブックは画像では１～２しかないですが、今後増えていきます。

①お見込みのとおりです。
②重複データはそのままのせる形です。
③のせる順番は、前に日付か番号をつけ、その順序。
④クリアせずに追加していく。
⑤シートに関しては、一番左のシートのみで構いません。
⑥Excel　職場のものは２０１３なので、２０１３を使用します。

お礼日時：2020/02/09 21:22

No.2 回答者： めぐみん_ 回答日時： 2020/02/09 15:36

画像がよくわかりませんが、１つのブックについて取得する『名前・住所』はその項目の１つ下の１対だけなのでしょうか？

何が、

＞シートの一行目しか取得できません。２行目以降も取得したいのですが、

と伝え解決したいのかが・・・・？

この回答へのお礼

大変わかりにくくて申し訳ありません。
最終的には、集計用の一覧.xlsx(xlsm)ブックに集計ボタンを置いて、それをクリックすると各ブック（名前.住所 １．xlsx,名前 住所 ２ xlsx）のシート１のデータが、一覧.xlsx(xlsm)ブックに転記されるようにしたいのです。
添付画像でいうと、名前.住所 １．xlsx シート１から、１行目 氏名 岡島 博・住所 東京都、２行目 山田 隆・堺市を転記するようにしたいのですが、一行目の氏名 岡島 博・住所 東京都しか上記のVBAでは転記されません。なお、岡田 敦 大阪狭山市は、名前 住所 ２ xlsx シート１の一行目となります。
なお、名前.住所 ．xlsxのブックは画像では１～２しかないですが、今後増えていきます。

お礼日時：2020/02/09 21:22