同じフォルダ内における複数ブックの特定項目集計

質問

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.8

n-jun

『名前』と『住所』双方を検索するコードを思いついて書いている点から、『名前』と『住所』は必ずしも隣り合わないって事なのかな？
例えば離れていたり、或いは逆になっていたりって感じとか？

書式が統一されてないって点で上記は気になる部分ですかね。

回答No.7

kkkkkm

> VBAをかじった知識しかない

自分でできないのですね。で、なんか半ば無理やりにやらされてる状態ですか。
多分以下のコードでできると思いますが、実際に動かしてみてください。
できるだけ元のコードを残しています。

Public Sub Test()
Dim wFile As String
Dim wFilePath As String
Dim i As Long
Dim Row_Count As Long '開いたブックのデータの行数

'Excelファイルが存在していたらファイル名を返す
wFile = Dir(ActiveWorkbook.Path & "\*.xlsx")
'カレントディレクトリに存在するExcelファイルを全て読み込む
Do While wFile <> ""
'開くExcelファイルのフルパスを取得
wFilePath = ActiveWorkbook.Path & "\" & wFile
'結果を一気に最終行からセルに代入 データは2列に決め打ち
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(Row_Count, 2).Value = File_Load(wFilePath, Row_Count)
'ファイル名も一気に書き込み
Cells(Rows.Count, "A").End(xlUp).Offset(1 - Row_Count, 2).Resize(Row_Count, 1) = wFile
'次のExcelファイルを取得
wFile = Dir()
Loop
End Sub

Function File_Load(ByVal wFilePath As String, ByRef Row_Count As Long) As Variant
Dim CurBookName As Variant
Dim wItem As String
Dim FoundCell As Range
Dim ColNo As Long
Dim RowNo As Long

wItem = "名前"
Workbooks.Open wFilePath
CurBookName = Application.ActiveWorkbook.Name
With Workbooks(CurBookName).Sheets(1)
.Activate
Set FoundCell = .Cells.Find(What:=wItem)
If Not FoundCell Is Nothing Then
'ここは直接FoundCellのRowとColumnを取れるのでセルに移動はいらない
'検索したセルに移動
'FoundCell.Select
'ColNo = ActiveCell.Column '列番号を取得
'RowNo = ActiveCell.Row '行番号を取得

ColNo = FoundCell.Column '列番号を取得
RowNo = FoundCell.Row '行番号を取得
'行数を計算
Row_Count = .Cells(Rows.Count, ColNo + 1).End(xlUp).Row - RowNo
'結果を一気に返す
File_Load = .Range(.Cells(RowNo + 1, ColNo), .Cells(Rows.Count, ColNo + 1).End(xlUp)).Value
End If
End With
Application.DisplayAlerts = False '確認メッセージの非表示
Workbooks(CurBookName).Close
Application.DisplayAlerts = True '確認メッセージの表示
End Function

回答No.6

n-jun

No.5です。
記載方法がどうとかよりも、複数のサイトに質問を上げてしまうと回答する側が違えば回答内容も色んなものが一気に流れ込みます。
経験不足であるならそれらを処理するのも大変でしょ。

更にそれぞれのサイトの回答者がダブっていれば『あっちとこっちとで言ってることが違う』などの混乱～放置になってしまいますからね。
まずは１つのサイトに絞ってどうしても解決しきれないようなら、その質問を閉じてから別のサイトで質問しましょう。

回答No.5

n-jun

自問自答ではなく『教えて！goo』で問われた事と返信をそのままコピペされているのでしょ。
解決に向けて動いないのか、又は協力業者の中に理解者がいるのか、その後に返信はありませんけどね。

お礼

本当に不快な思いさせて、申し訳ありません。
VBAをかじった知識しかない私が、人数の削減の影響を受け、業務上やらざるを得ない状況になり、少しでもわかるように素人なりにコメントを補足したのですが、不適切な記載方法でした。
お許しください。

回答No.4

kkkkkm

自問自答してないで、やることやってください(笑)

お礼

おっしゃるとおりです。
不快な思いさせて申し訳ありません。

回答No.3

imogasi

質問の標題が、「特定項目集計 」の「集計」とあるので、数字項目を合計するのかと思ったが、質問を読むと、１つのシートにデータ行を「集約」したい、ということのようだ。
紛らわしい。注意。
またコード行数が多すぎる。ここまで長くならない見込み。
この課題は、１か月に１回ぐらい質問が出る課題で、「またか」といったものだ。
ーー
・集約するシートは１ブックあたり１シートである、のかな。
・シート名は（各ブックで）同じなのかな。共通するシート名部分があるのかな。後者ならその状況を説明が必要だろう。
ーー
集約用のブック以外を読んで、シートを名前で指定し（または探して）、
データをCurrentＲegionなどで採ってコピーし、集約シートの（その時点での！）最終行の次の行以下に張り付ければ仕舞いではないか。
・元データでは、住所・氏名以外の項目もデータ列としてあるのか？
・住所・氏名のある列の位置は、ブックごとにまちまちか？
これらを注記すべきだろう。他人には判らないよ。
ーー
集約シートの尾の時点での最下行はEnd(xlIp)などを使うのが、常道だろう。
この手法は、小生などは、毎度使っているものだ（便利）。
ーー
データのコピー貼り付けで、（各）別ブック・別シートーー＞集約ブック・集約シートの２つか、別世界なので、それを表現する手法を学んだか？

お礼

ご助言ありがとうございます。
また私の質問の仕方が悪く、皆さまにはお手数をおかけするばかりか、不快な思いさせてしました。
大変申し訳ありません。

回答No.2

kkkkkm

> 大変わかりにくくて申し訳ありません。

いえ、わかりますよ。多分(笑)
回答したコードはファイルを開くとか(すでにできているから)は除いていますので、そこは現在のコードにご自身で当てはめてやってみてくださいということなんです。
回答ではSheet2を参照してSheet2のデータをコードを書いているシートに転記していますので、Sheet2の部分を各ブックのシート1に設定し直すと、必要なデータ(2行目以降全て)が転記されます。1行目は項目名ですから2行目からですよね。

補足

先ほど送付した補足コメントですが、シートとブックを取り違えて記載しておりましたので、一部修正いたします。
後、補足の説明を追加いたしました。

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

補足説明
(1)「一覧.xlsm」と同じフォルダにある「○○○.xlsx」の「名前」と「住所」の列データとその「ファイル名」を「一覧.xlsm」にまとめるだけのような感じですが間違いありませんか？
(2) 重複データはどうするのでしょうか？
　(a) そのまま全て載せる
　(b) どれか１つだけ載せる
　(c) その他（具体的に説明して下さい）
(3) 載せる順番になにかルールはありますか？
(4) 実行ごとに１度データはクリアした方が良いですか？
　(d) 毎回クリアする
　(e) クリアせず追加していく
　(f) その他（具体的に説明して下さい）
(5) シートに関して
　(g) 一番左のシートのみ処理する
　(h)「○○○.xlsx」は全てのシートから１行目に「名前」と「住所」が有る物を使う
　(i) その他（具体的に説明して下さい）
(6) Excel のバージョンは何ですか？。

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

回答No.1

kkkkkm

こんな感じというものです。
Sheet2を対象にしていますが開いたブックを対象にしてください。
ブックを開かないのでwFilePathは""にしてその操作は除外しています。

Sub Test()
Dim Row_Count As Long '開いたブックのデータの行数
'結果を一気に最終行からセルに代入 データは2列に決め打ち
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(Row_Count, 2).Value = File_Load("", Row_Count)
End Sub

Function File_Load(ByVal wFilePath As String, ByRef Row_Count As Long) As Variant
wItem = "名前"
With Sheets("Sheet2")
.Activate
Set FoundCell = .Cells.Find(What:=wItem)
If Not FoundCell Is Nothing Then
'検索したセルに移動
FoundCell.Select
ColNo = ActiveCell.Column '列番号を取得
RowNo = ActiveCell.Row '行番号を取得
'行数を計算
Row_Count = .Cells(Rows.Count, ColNo + 1).End(xlUp).Row - RowNo
'結果を一気に返す
File_Load = .Range(.Cells(RowNo + 1, ColNo), .Cells(Rows.Count, ColNo + 1).End(xlUp)).Value
End If
End With
End Function

お礼

早速回答いただきありがとうございます。

補足

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