複数のエクセルファイルからデータ抽出とまとめる

集約一覧表と同じ場所にある複数のサブフォルダ全てにある全てのエクセルブックからデータを抽出して集約一覧表に表示させたいのですが、どのようにマクロを組めばいいのかわかりません。
抽出するデータは　B1、B3、B7、B9　です。これを集約一覧の２行目から順番に各行に各エクセルブックの抽出データをB1をA列、B３をB列、B7をC列、B9をD列に表示させできることならE列に各ブックへのハイパーリンクを自動で貼るマクロを作りたいと思っています。
更に今後、集約一覧をフォルダごと移動することも考えて絶対パスを自動で取得できるようにもしたいです。
初心者の為、いろいろエクセルのガイドブックやいろんなサイトの似たような質問をたどってみましたがよく理解できず困っています。どなたかご教示いただけませんでしょうか？

No.3 ベストアンサー 回答者： cj_mover 回答日時： 2013/04/05 17:28

こんにちは。

動作は確認できたのでしょうかね？まあ、さておき。
レスを拝見したので、コードのコメント、多少解り易く、読み易くしてみました。
２、３、不適切なコメントもあったので、再度、差し換え、ということで。
コードの内容はまったく同じです。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8025281()
　　Dim shtP As Worksheet ' 出力先シートを参照
　　Dim arrSubF() As String ' フォルダ名を格納する、文字列型配列変数
　　Dim sPath As String ' マクロを登録したブックが格納されたフォルダへのパス名
　　Dim sTmp As String ' Dir()関数で検索にヒットしたフォルダ名、ファイル名を一時的に格納
　　Dim sSubF As String ' フォルダ名をラインフィード区切りで列挙する文字列変数
　　Dim nRow As Long ' 出力先の行位置
　　Dim i As Long ' For...Nextループで、フォルダ名配列を順次処理する為のインデックスを指す変数

' ' > 今後、集約一覧をフォルダごと移動することも考えて絶対パスを自動で取得
　　sPath = ThisWorkbook.Path & "\"

' ' サブフォルダ名取得（ラインフィード区切りの列挙文字列）

' ' サブフォルダ名を検索
　　sTmp = Dir(sPath & "*.*", vbDirectory)

' ' フォルダ名が見つかったら
　　Do While sTmp <> ""

' ' 検索に掛かった名前がフォルダ名であることを確かめたら
　　　　If GetAttr(sPath & sTmp) And vbDirectory Then

' ' 『上位階層フォルダへの参照を示すフォルダ名："." と ".."』 は除いて
　　　　　　If Not sTmp Like ".*" Then

' ' サブフォルダ名をラインフィード区切りで列挙
　　　　　　　　sSubF = sSubF & vbLf & sTmp & "\"

　　　　　　End If
　　　　End If

' ' 次のサブフォルダ名を検索
　　　　sTmp = Dir()

　　Loop

' ' ラインフィード区切りで列挙した文字列から、サブフォルダ名配列を設定（arrSubF(0)は空）
　　arrSubF() = Split(sSubF, vbLf)

' ' 出力先シートへの参照をオブジェクト変数に確保
　　Set shtP = ThisWorkbook.Sheets(1) ' ←◆運用に合わせてシートを指定◆（シート名で指定するなら...ThisWorkbook.Sheets("Sheet1")）

' ' arrSubF(i)　サブフォルダ名配列のインデックスでループ（０はスルー）
　　For i = 1 To UBound(arrSubF)

' ' 各サブフォルダ毎にファイル名取得
' ' ファイル名を検索 ' ◆↓運用に合わせて拡張子を指定◆
　　　　sTmp = Dir(sPath & arrSubF(i) & "*.xl*") ' & "*.xls*") ' & "*.xlsx")

' ' ファイル名が見つかったら
　　　　Do While sTmp <> ""

' ' 元データ側のブックをひとつずつ開き
　　　　　　With Workbooks.Open(sPath & arrSubF(i) & sTmp)

' ' 開いたブックの先頭にあるシートを元データとしてWith節で参照して
　　　　　　　　With .Sheets(1) ' ←◆運用に合わせてシートを指定◆

' ' 出力先の行（最下行の一つ下空いている行）位置を取得
　　　　　　　　　　nRow = shtP.Cells(Rows.Count, "A").End(xlUp).Row + 1

' ' > B1をA列、B３をB列、B7をC列、B9をD列に表示させ
　　　　　　　　　　shtP.Cells(nRow, "A").Value = .Range("B1").Value
　　　　　　　　　　shtP.Cells(nRow, "B").Value = .Range("B3").Value
　　　　　　　　　　shtP.Cells(nRow, "C").Value = .Range("B7").Value
　　　　　　　　　　shtP.Cells(nRow, "D").Value = .Range("B9").Value

　　　　　　　　End With

' ' >できることならE列に各ブックへのハイパーリンク
　　　　　　　　shtP.Hyperlinks.Add shtP.Cells(nRow, "E"), sPath & arrSubF(i) & sTmp, , , arrSubF(i) & sTmp

' ' 元データ側のブックを閉じる
　　　　　　　　.Close False

　　　　　　End With

' ' 次のファイル名を検索
　　　　　　sTmp = Dir()

　　　　Loop

　　Next i

' ' オブジェクト変数の参照を解放（省略可）
　　Set shtP = Nothing
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝


' それでは、また。

この回答への補足

読み込んだ各エクセルのブックを自動で閉じることができません？
どのようにしたらいいでしょうか？
頼りっきりで申し訳ありません。

補足日時：2013/04/08 09:33

No.6 回答者： cj_mover 回答日時： 2013/04/08 20:23

#5の訂正です。

（ミスりました。すみません）


プロシージャの先頭に以下
' ' ------------------------------
' ' 画面更新を一時停止(追加）
　　Application.ScreenUpdating = False
' ' 警告・メッセージ ダイアログの表示抑止(対策【１】追加）
　　Application.DisplayAlerts = False
' ' イベント発効　抑止（対策【２】追加）
　　Application.EnableEvents = False
' ' 自動計算　停止（対策【３】追加）
　　Application.Calculation = xlCalculationManual ' 訂正箇所
' ' ------------------------------

プロシージャの最後に以下
' ' ------------------------------
' ' 画面更新一時停止を解除（追加）
　　Application.ScreenUpdating = True
' ' 警告・メッセージ ダイアログの表示再開（対策【１】追加）
　　Application.DisplayAlerts = True
' ' イベント発効　再開（対策【２】追加）
　　Application.EnableEvents = True ' 訂正箇所
' ' 自動計算　再開（対策【３】追加）
　　Application.Calculation = xlCalculationAutomatic
' ' ------------------------------

何か、気が付いたことでもあれば、また知らせてください。

この回答へのお礼

ありがとうございます。

自分も.Close Falseで閉じることができない理由が分かりません。
今後のメンテの為にも原因を把握していくようにします。

本当に助かりました。
しかも、わかりやすい注釈やアフターフォローすごく感激しました。

重ねてありがとうございます。

お礼日時：2013/04/09 14:58

No.5 回答者： cj_mover 回答日時： 2013/04/08 20:03

こんにちは。

実装コード拝見して、こちらでも確認しました。
こちらでは、私の意図した通りダイアログは表示されませんし、
コードを見る限り、ダイアログが表示されることが謎です。

' ' 元データ側のブックを閉じる
.Close False

↑これ、引数の False の意味ですけれど、
Workbook オブジェクトに未保存のデータがあったとしても構わず、
保存せずに閉じる、という意味なので、
保存を求めるダイアログに対して予めキャンセルしている意味なのです。

それでも保存を求めてくるとしたら、各ブックに
Workbook_BeforeClose イベントが設定されていて、
そちらの挙動だったりするのかも？？？しれません。
→対策【１】一時的にイベントを止めます。

私は最初に回答付けた段階で２０件ほどダミーサンプルブックを用意してましたが、
A1に数式 =NOW() を置いてありますから、
通常は開いただけで、編集を加えなくても、閉じる時に保存を求められるブック、
が在るという想定で、.Close False と書いたのですが、
何故、そのような現象が起きるのかは想定外で今なお理解の外です。
→対策【２】一時的にExcelでのダイアログ表示を表示しない設定にします。
ひょっとして、ブック間の数式の参照またはリンクが循環している？？？とか
→対策【３】一時的にExcelでの自動再計算を抑えます。

プロシージャの先頭に以下
' ' ------------------------------
' ' 画面更新を一時停止(追加）
　　Application.ScreenUpdating = False
' ' 警告・メッセージ ダイアログの表示抑止(対策【１】追加）
　　Application.DisplayAlerts = False
' ' イベント発効　抑止（対策【２】追加）
　　Application.EnableEvents = False
' ' 自動計算　停止（対策【３】追加）
　　Application.Calculation = xlCalculationAutomatic
' ' ------------------------------

プロシージャの最後に以下
' ' ------------------------------
' ' 画面更新一時停止を解除（追加）
　　Application.ScreenUpdating = True
' ' 警告・メッセージ ダイアログの表示再開（対策【１】追加）
　　Application.DisplayAlerts = True
' ' イベント発効　再開（対策【２】追加）
　　Application.EnableEvents = False
' ' 自動計算　再開（対策【３】追加）
　　Application.Calculation = xlCalculationAutomatic
' ' ------------------------------

ただ、これらの対策は本来、必要なものではありませんから、
原因側で対処するのが本来妥当で、場当たり的な対症療法に過ぎません。
現象に改善が見られないなら、コードから外しておいた方がよいです。
特別害のある記述はありませんが、
知らない人がメンテしようとコードを見たら、その記述があるせいで、
要らぬ警戒をして、不調に終わる可能性もあるので。

今のところ、以上です。

No.4 回答者： cj_mover 回答日時： 2013/04/08 11:00

> 読み込んだ各エクセルのブックを自動で閉じることができません？

もう少し具体的な情報をくださいませ。
最初に書いたように、不足した情報をこちらで勝手に補って書いたコードですから
条件が違えば期待通りに動くものではないです。
こちらが想定しているものと、質問者さんが必要としているものと、
ここが違う、という風に限定して行けるように話が出来ないと、ここから前には進めません。

Sub 要確認　で、対象ブックを捉えていることは確認できたのでしょうか？
それが、まず第一歩です。確認が取れたなら、
回答No.3で提示したコードを”過不足なく”コピペして実行・確認してください。
元データのブックについては、ひとつずつ開いては閉じ、するように書いています。
”自動で閉じることができません”とは、色んな意味にとれますが、
エラーでしょうか？それとも保存を求めるダイアログが表示されるということでしょうか？
エラーならば、エラーメッセージが表示されたダイアログの
（１）エラー内容を示すメッセージをメモしておく
（２）[デバッグ]を押して、コード上の何処で停まっているかメモしておく
情報がないと、こちらも何もできません。
保存を求めるダイアログは表示されないように書いています。
もし表示されるようなら、何か書き換えたのでしょうか？
それなら、そのコードをまるまるコピーして補足欄にでも貼ってください。
自力で解決するなら、書き換えた部分をひとつひとつそちらで確認するしかないです。

解決へのお手伝いはしたいですけれど、遠隔ですので、
今見えている範囲でこちらから助言できるのはこれで精いっぱいです。

この回答への補足

元データのブックがひとつずつ開いて、閉じる際に保存を求めるダイアログが表示されます。特に変にいじったわけではないのですが…
元データのブック数を考えると、この部分も何とかクリアしたいところです。
本当に申し訳ないです。何とか解決できるようにお願いします。

Sub kesu()
'
' 一覧消去
'

'
Range("A2:I1001").Select
Selection.ClearContents
Range("F4").Select
End Sub

Sub itiransakusei()
Dim shtP As Worksheet ' 出力先シートを参照
Dim arrSubF() As String ' フォルダ名を格納する、文字列型配列変数
Dim sPath As String ' マクロを登録したブックが格納されたフォルダへのパス名
Dim sTmp As String ' Dir()関数で検索にヒットしたフォルダ名、ファイル名を一時的に格納
Dim sSubF As String ' フォルダ名をラインフィード区切りで列挙する文字列変数
Dim nRow As Long ' 出力先の行位置
Dim i As Long ' For...Nextループで、フォルダ名配列を順次処理する為のインデックスを指す変数

' ' 画面更新を一時停止(追加）
Application.ScreenUpdating = False

' ’一覧データ削除（追加）
Call kesu

' ' > 今後、集約一覧をフォルダごと移動することも考えて絶対パスを自動で取得
sPath = ThisWorkbook.Path & "\"

' ' サブフォルダ名取得（ラインフィード区切りの列挙文字列）

' ' サブフォルダ名を検索
sTmp = Dir(sPath & "*.*", vbDirectory)

' ' フォルダ名が見つかったら
Do While sTmp <> ""

' ' 検索に掛かった名前がフォルダ名であることを確かめたら
If GetAttr(sPath & sTmp) And vbDirectory Then

' ' 『上位階層フォルダへの参照を示すフォルダ名："." と ".."』 は除いて
If Not sTmp Like ".*" Then

' ' サブフォルダ名をラインフィード区切りで列挙
sSubF = sSubF & vbLf & sTmp & "\"

End If
End If

' ' 次のサブフォルダ名を検索
sTmp = Dir()

Loop

' ' ラインフィード区切りで列挙した文字列から、サブフォルダ名配列を設定（arrSubF(0)は空）
arrSubF() = Split(sSubF, vbLf)

' ' 出力先シートへの参照をオブジェクト変数に確保
Set shtP = ThisWorkbook.Sheets(1) ' ←◆運用に合わせてシートを指定◆（シート名で指定するなら...ThisWorkbook.Sheets("Sheet1")）

' ' arrSubF(i)　サブフォルダ名配列のインデックスでループ（０はスルー）
For i = 1 To UBound(arrSubF)

' ' 各サブフォルダ毎にファイル名取得
' ' ファイル名を検索 ' ◆↓運用に合わせて拡張子を指定◆
sTmp = Dir(sPath & arrSubF(i) & "*.xl*") ' & "*.xls*") ' & "*.xlsx")

' ' ファイル名が見つかったら
Do While sTmp <> ""

' ' 元データ側のブックをひとつずつ開き
With Workbooks.Open(sPath & arrSubF(i) & sTmp)

' ' 開いたブックの先頭にあるシートを元データとしてWith節で参照して
With .Sheets("メイン") ' ←◆運用に合わせてシートを指定◆（修正）

' ' 出力先の行（最下行の一つ下空いている行）位置を取得
nRow = shtP.Cells(Rows.Count, "A").End(xlUp).Row + 1

' ' > B1をA列、B３をB列、B7をC列、B9をD列に表示させ
shtP.Cells(nRow, "A").Value = .Range("B1").Value
shtP.Cells(nRow, "B").Value = .Range("B3").Value
shtP.Cells(nRow, "C").Value = .Range("B7").Value
shtP.Cells(nRow, "D").Value = .Range("B9").Value

End With

' ' >できることならE列に各ブックへのハイパーリンク
shtP.Hyperlinks.Add shtP.Cells(nRow, "E"), sPath & arrSubF(i) & sTmp, , , arrSubF(i) & sTmp

' ' 元データ側のブックを閉じる
.Close False

End With

' ' 次のファイル名を検索
sTmp = Dir()

Loop

Next i

' ' オブジェクト変数の参照を解放（省略可）
Set shtP = Nothing

' ' 画面更新一時停止を解除（追加）
Application.ScreenUpdating = True
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

補足日時：2013/04/08 12:31

No.2 回答者： cj_mover 回答日時： 2013/04/04 03:27

あ！すみません。

もしかして、ファイル名やフォレダ名に半角スペースを使っている場合を
考慮していませんでした。（自分の仕事場のルールに慣れきってしまって）
提示済のコード、２つとも差し替えでお願いします。
失礼しました。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub 要確認()
　　Dim arrSubF() As String
　　Dim sPath As String, sTmp As String, sSubF As String
　　Dim i As Long

　　sPath = ThisWorkbook.Path & "\"
　　Debug.Print "●●" & sPath
　　sTmp = Dir(sPath & "*.*", vbDirectory)
　　Do While sTmp <> ""
　　　　If GetAttr(sPath & sTmp) And vbDirectory Then
　　　　　　If Not sTmp Like ".*" Then
　　　　　　　　sSubF = sSubF & vbLf & sTmp & "\"
　　　　　　End If
　　　　End If
　　　　sTmp = Dir()
　　Loop
　　arrSubF() = Split(sSubF, vbLf)
　　For i = 1 To UBound(arrSubF)
　　　　Debug.Print , "●"; arrSubF(i)
　　　　sTmp = Dir(sPath & arrSubF(i) & "*.xl*") ' & "*.xls*") ' & "*.xlsx")
　　　　Do While sTmp <> ""
　　　　　　Debug.Print , , sTmp
　　　　　　sTmp = Dir()
　　　　Loop
'　　　　Stop
　　Next i
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8025281()
　　Dim shtP As Worksheet
　　Dim arrSubF() As String
　　Dim sPath As String, sTmp As String, sSubF As String
　　Dim nRow As Long
　　Dim i As Long

' ' > 今後、集約一覧をフォルダごと移動することも考えて絶対パスを自動で取得
　　sPath = ThisWorkbook.Path & "\"

' ' サブフォルダ名取得（半角スペース区切りの列挙文字列）
' ' サブフォルダを検索
　　sTmp = Dir(sPath & "*.*", vbDirectory)
　　Do While sTmp <> ""
' ' 検索に掛かった名前がフォルダであることを確かめたら
　　　　If GetAttr(sPath & sTmp) And vbDirectory Then
' ' フォルダ名 "." と ".." は除く
　　　　　　If Not sTmp Like ".*" Then
' ' サブフォルダ名を列挙
　　　　　　　　sSubF = sSubF & vbLf & sTmp & "\"
　　　　　　End If
　　　　End If
' ' 次のサブフォルダを検索
　　　　sTmp = Dir()
　　Loop

' ' サブフォルダ名を配列化（arrSubF(0)は空）
　　arrSubF() = Split(sSubF, vbLf)

' ' 出力先シートへの参照を確保
　　Set shtP = ThisWorkbook.Sheets(1)

' ' サブフォルダ名配列のインデックスでループ（０はスルー）
　　For i = 1 To UBound(arrSubF)
' ' 各サブフォルダ毎にファイル名取得（）
' ' ファイルを検索
　　　　sTmp = Dir(sPath & arrSubF(i) & "*.xl*") ' & "*.xls*") ' & "*.xlsx")
' ' ファイル名が見つかったら
　　　　Do While sTmp <> ""
' ' ブックを開く
　　　　　　With Workbooks.Open(sPath & arrSubF(i) & sTmp)
' ' 開いたブックの先頭にあるシートを出力先として
　　　　　　　　With .Sheets(1)
' ' 出力先の行（空いている最下行）位置を取得
　　　　　　　　　　nRow = shtP.Cells(Rows.Count, "A").End(xlUp).Row + 1
' ' > B1をA列、B３をB列、B7をC列、B9をD列に表示させできることならE列に各ブックへのハイパーリンク
　　　　　　　　　　shtP.Cells(nRow, "A").Value = .Range("B1").Value
　　　　　　　　　　shtP.Cells(nRow, "B").Value = .Range("B3").Value
　　　　　　　　　　shtP.Cells(nRow, "C").Value = .Range("B7").Value
　　　　　　　　　　shtP.Cells(nRow, "D").Value = .Range("B9").Value
　　　　　　　　　　shtP.Hyperlinks.Add shtP.Cells(nRow, "E"), sPath & arrSubF(i) & sTmp, , , arrSubF(i) & sTmp
　　　　　　　　End With
' ' ブックを閉じる
　　　　　　　　.Close False
　　　　　　End With
' ' 次のファイルを検索
　　　　　　sTmp = Dir()
　　　　Loop
　　Next i

　　Set shtP = Nothing
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

この回答へのお礼

ありがとうございます。
いつまでも初心者などと言わないように教えて頂いたコードを理解していくように頑張ります。

お礼日時：2013/04/05 14:05

No.1 回答者： cj_mover 回答日時： 2013/04/03 22:57

こんにちは。

オーソドックスな手法で書くことを意識してみました。

こちらから見て条件が限定されていなくて、とりあえず仮の条件付けをしたのが以下。
　マクロの登録先は"集約一覧表.xlsm" ？ → とりあえずマクロ登録先＝集約一覧表
　サブフォルダの階層数は？ → とりあえず１階層下まで検索
　拡張子？　.xlsx ? .xlsm ? .xls ? .xla ? → とりあえず .xl で始まるすべてのファイル
　検索先シート指定？　シート名とか何番目のシートとか？ → とりあえずSheets(1)
　出力先シート指定？　〃 → とりあえずマクロを登録したブックのSheets(1)に出力

まずは以下の確認用コードを実行してみて、思惑通りかどうか、確認してみてください。
実行するとイミディエイトウィンドウに
●●集約一覧表の絶対パス
　　●サブフォルダ名
　　　　ファイル名
という内容が階層表示されます。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub 要確認()
　　Dim arrSubF() As String
　　Dim sPath As String, sTmp As String, sSubF As String
　　Dim i As Long

　　sPath = ThisWorkbook.Path & "\"
　　Debug.Print "●●" & sPath
　　sTmp = Dir(sPath & "*.*", vbDirectory)
　　Do While sTmp <> ""
　　　　If GetAttr(sPath & sTmp) And vbDirectory Then
　　　　　　If Not sTmp Like ".*" Then
　　　　　　　　sSubF = sSubF & " " & sTmp & "\"
　　　　　　End If
　　　　End If
　　　　sTmp = Dir()
　　Loop
　　arrSubF() = Split(sSubF)
　　For i = 1 To UBound(arrSubF)
　　　　Debug.Print , "●"; arrSubF(i)
　　　　sTmp = Dir(sPath & arrSubF(i) & "*.xl*") ' & "*.xls*") ' & "*.xlsx")
　　　　Do While sTmp <> ""
　　　　　　Debug.Print , , sTmp
　　　　　　sTmp = Dir()
　　　　Loop
'　　　　Stop
　　Next i
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

フォルダとファイルの状況と条件付けが確認取れたなら、以下を試して確認してください。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8025281()
　　Dim shtP As Worksheet
　　Dim arrSubF() As String
　　Dim sPath As String, sTmp As String, sSubF As String
　　Dim nRow As Long
　　Dim i As Long

' ' > 今後、集約一覧をフォルダごと移動することも考えて絶対パスを自動で取得
　　sPath = ThisWorkbook.Path & "\"

' ' サブフォルダ名取得（半角スペース区切りの列挙文字列）
' ' サブフォルダを検索
　　sTmp = Dir(sPath & "*.*", vbDirectory)
　　Do While sTmp <> ""
' ' 検索に掛かった名前がフォルダであることを確かめたら
　　　　If GetAttr(sPath & sTmp) And vbDirectory Then
' ' フォルダ名 "." と ".." は除く
　　　　　　If Not sTmp Like ".*" Then
' ' サブフォルダ名を列挙
　　　　　　　　sSubF = sSubF & " " & sTmp & "\"
　　　　　　End If
　　　　End If
' ' 次のサブフォルダを検索
　　　　sTmp = Dir()
　　Loop

' ' サブフォルダ名を配列化（arrSubF(0)は空）
　　arrSubF() = Split(sSubF)
　　
' ' 出力先シートへの参照を確保
　　Set shtP = ThisWorkbook.Sheets(1)

' ' サブフォルダ名配列のインデックスでループ（０はスルー）
　　For i = 1 To UBound(arrSubF)
' ' 各サブフォルダ毎にファイル名取得（）
' ' ファイルを検索
　　　　sTmp = Dir(sPath & arrSubF(i) & "*.xl*") ' & "*.xls*") ' & "*.xlsx")
' ' ファイル名が見つかったら
　　　　Do While sTmp <> ""
' ' ブックを開く
　　　　　　With Workbooks.Open(sPath & arrSubF(i) & sTmp)
' ' 開いたブックの先頭にあるシートを出力先として
　　　　　　　　With .Sheets(1)
' ' 出力先の行（空いている最下行）位置を取得
　　　　　　　　　　nRow = shtP.Cells(Rows.Count, "A").End(xlUp).Row + 1
' ' > B1をA列、B３をB列、B7をC列、B9をD列に表示させできることならE列に各ブックへのハイパーリンク
　　　　　　　　　　shtP.Cells(nRow, "A").Value = .Range("B1").Value
　　　　　　　　　　shtP.Cells(nRow, "B").Value = .Range("B3").Value
　　　　　　　　　　shtP.Cells(nRow, "C").Value = .Range("B7").Value
　　　　　　　　　　shtP.Cells(nRow, "D").Value = .Range("B9").Value
　　　　　　　　　　shtP.Hyperlinks.Add shtP.Cells(nRow, "E"), sPath & arrSubF(i) & sTmp, , , arrSubF(i) & sTmp
　　　　　　　　End With
' ' ブックを閉じる
　　　　　　　　.Close False
　　　　　　End With
' ' 次のファイルを検索
　　　　　　sTmp = Dir()
　　　　Loop
　　Next i

　　Set shtP = Nothing
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

以上です。