Excel VBA でサブルーチンをループさせたいのですが

Question

お世話になっております。
VBA初級者です。

Excel VBA で任意のフォルダからサブフォルダまで再帰的に呼び出し、複数ファイルから作成日・名称・金額を複数行取得し、それぞれのファイル名も取得し、呼び出し元のブックの各行、各列に列挙していきたいと考えております。

今回、以下のコードでは呼び出し元ファイルと同じフォルダにある複数ファイルからデータをそれぞれ1行分のみ取得できます。どれもループが上手く働いておらず、困り果てております。

どのように修正すれば期待通りの動作を致しますでしょうか。何卒よろしくご教示下さいませ。

--
先日、『Excel VBA でFunctionが呼び出せません』のタイトルでこちらで相談させていただいた者です。
https://oshiete.goo.ne.jp/qa/11972550.html

せっかく皆様のアドバイスを頂いた上に、親切な方に詳細なコードを書いていただいたにもかかわらず私の実力ではコードを読み切れず、自分の集めてきたコードに戻りました。せっかくのご親切を無駄にしてしまい誠に申し訳ございません。
--------------------------------------------------------------
Dim buf As String, f As Object
Dim cnt As Long
Dim wFile As String
Dim wFilePath As String
Dim r As Long

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

cnt = 1
Call Subroutine("\\xxxxx\xxxxx\xxxxx")

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

'先頭行を指定
r = 2

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

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

'作成日・名称・金額を取得し配列に格納する（区切り文字：|）
strData = Split(File_Load(wFilePath), "|")

'作成日
Cells(r, 1) = strData(0)

'名称
Cells(r, 2) = strData(1)

'金額
Cells(r, 3) = strData(2)

'ファイル名
Cells(r, 4) = wFile

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

'行数をカウント
r = r + 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 Variant
Dim FoundCell As Range
Dim i As Long

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

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

'検索する項目を配列に格納
wItem = Array("作成日", "名称", "金額　(税込)")

'検索する
For i = LBound(wItem) To UBound(wItem)
If strValue = "*|*" Then
GoTo Continue ' Continue: の行へ処理を飛ばす
End If
Workbooks.Open wFilePath
Worksheets("ワークシート名").Activate
Set FoundCell = Worksheets("ワークシート名").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 = Selection.Offset(RowNo + 1).Value
Else
'2番目以降の項目は|で区切る
strValue = strValue & "|" & Selection.Offset(RowNo + 1).Value
End If
End If
Next i

Continue:
'結果を返す
File_Load = strValue

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

End Function

Sub Subroutine(Path As String)

buf = Dir(Path & "\■*.xlsm")
Do While buf <> ""
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Subroutine(f.Path)
Next f
End With
End Sub

インデントが効かず可読性の低いコードになっていることをお詫び申し上げます。

補足日時：2020/10/25 17:09
通報する
・呼び出し先はサブフォルダに散らばっている。
・呼び出し先はタイトルは同じもののフォーマットが異なるものが混在
・呼び出し元に複数の呼び出し先からデータを下記のように集計
呼び出し元
作成日　　　　　名称　　　　　　金額　　ファイル名
2020/10/10　　株式会社○○　　550　　■○○.xlsm
2020/10/10　　株式会社○○　　550　　■○○.xlsm
2020/10/10　　株式会社○○　　550　　■○○.xlsm
呼び出し先（■*.xlsm）
NO.　名称　　発注番号　　発注作成日　　名称　　　　　金額
1　　申請　　11-1a　　　2020/10/10　株式会社○○　　550
2　　基礎　　　　　　　　　　　　　　　株式会社○○
3　　その他　11-1a　　　2020/10/10　株式会社○○　　550

補足日時：2020/10/26 09:15
通報する
文字数制限からぶしつけな書きようになってしまいましたが、上記が関連ファイルの簡易的な図でございます。

補足日時：2020/10/26 09:17
通報する
皆様、ご返答が遅れましたことをまずお詫び申し上げます。
ここ3日ほど体調を崩しており、ご返答もままならない状態でした。
その間もご返答いただいており、申し訳ないやらありがたいやらで心底感謝しております。
今から精読させていただきたいと思いますので、改めて個別にご返答差し上げたいと思います。

補足日時：2020/10/30 08:59
通報する

通報する

Qchan1962 · Accepted Answer

＃８
Option Explicit
Dim n As Long
Dim TargetFile()
Sub StartProgram()
Dim i As Long, ii As Long, j As Long
Dim FoundCell As Range
Dim strValue()
Dim wFile As String, wItem As Variant
Const filepath As String = "\xxxxx\xxxxx\xxxxx"
　　On Error Resume Next
　　Erase TargetFile
　　n = 0
　　Call getFileList(filepath)
　　If UBound(TargetFile) < 0 Then Exit Sub
　　'検索する項目を配列に格納
　　wItem = Array("作成日", "名称", "金額　(税込)")
　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False

For i = 0 To UBound(TargetFile)
　　　　ReDim strValue(200, UBound(wItem) + 1)
　　　　wFile = Mid(TargetFile(i), InStrRev(TargetFile(i), "") + 1)
　　　　With Application.Workbooks.Open(TargetFile(i))
　　　　　　Worksheets("ワークシート名").Activate
　　　　　　For ii = LBound(wItem) To UBound(wItem)
　　'検索する
　　　　　　　　Set FoundCell = ActiveSheet.Cells.Find(What:=wItem(ii))
　　　　　　　　If FoundCell Is Nothing Then
　　'検索出来なかった場合
　　　　　　　　　　GoTo Continue
　　　　　　　　Else
　　'検索したセル
　　　　　　　　　　For j = 0 To ActiveSheet.Cells(Rows.Count, FoundCell.Column).End(xlUp).Row - FoundCell.Row
　　　　　　　　　　　　strValue(j, ii) = FoundCell.Offset(j + 1).Value
　　　　　　　　　　　　strValue(j, 3) = wFile
　　　　　　　　　　Next j
　　　　　　　　End If
Continue:
　　　　　　Next ii
　　　　　　.Save
　　　　　　.Close
　　　　End With
　　　　Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(strValue) + 1, 4) = strValue
　　Next
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End Sub

Sub getFileList(filepath)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim objFol As Object, objFile As Object
　　For Each objFol In FSO.GetFolder(filepath).SubFolders
　　　　Call getFileList(objFol.Path)
　　Next
　　For Each objFile In FSO.GetFolder(filepath).Files
　　　　If objFile.Name Like "■*.xlsm" Then
　　　　　　ReDim Preserve TargetFile(n)
　　　　　　TargetFile(n) = objFile.Path
　　　　　　n = n + 1
　　　　End If
　　Next
End Sub

Qchan1962 · Answer

こんばんは、、＃２です。
＞せっかくのご親切を無駄にしてしまい誠に申し訳ございません。
そんなことはありません。しっかり理解して使用する、とても良い事と思います。

（遊びで）くたくたで思考がほぼ停止ですが、
前回の再帰処理でファイル取得するコードで実行部分を追加したものを書きます。（一応最後まで書ききった方が分からなくても参考になるかも知れませんので）
このご質問の回答ではありませんので、参考まで
データを取得抽出する部分なんですが、2次配列にしてしまった関係で
手直しが必要かも知れません。
そのままでも動きますが、1シート200行のデータなので200を変えるか
配列の組み方を変えてください。
ReDim strValue(200, UBound(wItem) + 1)

検索キーワードは、項目タイトルにあってもなくても良いですが
一意である必要があります。（行、列はどこでも多分大丈夫）

ここまで書いて、やめようかと思いましたが、、コード書いたので、投稿します。
なぜでしょう？文字数オーバーでないのに投稿できない。。
続く

fujillin · Answer

以下、簡単な「再帰」の例として…

Option Explicit
Dim Fso As Object, recCell As Range

Const startFolder = "\xxxxx\xxxxx\xxxxx" '指定フォルダ（トップフォルダ）
Const targetFile = "■*.xlsm" '対象とするファイルの識別名
Const targetSheet = "yyyyyyyyy" '対象とするシート名
Const wItem1 = "名前", wItem2 = "日付"

Sub main()
'準備（初期設定、シートクリア）
Set Fso = CreateObject("Scripting.FileSystemObject")
Set recCell = ThisWorkbook.Worksheets(1).Cells(1, 1)
recCell.Worksheet.Cells.Clear

'フォルダチェック―呼び出し
If Fso.FolderExists(startFolder) Then
　Call FolderOUT(Fso.Getfolder(startFolder))
End If
recCell.Value = "--- END OF LIST ---"
End Sub

'*** フォルダ内出力処理（再帰）***
Sub FolderOUT(ByRef folder As Object)
Dim f As Object
'全サブフォルダを処理
For Each f In folder.SubFolders
　Call FolderOUT(f)
Next f
'全ファイルを処理
For Each f In folder.files
　If f.Name Like targetFile Then Call FileOUT(f)
Next f
End Sub

'*** 一ファイル分の出力処理 ***
'---適当に書き直してください
Sub FileOUT(ByRef file As Object)
Dim wb As Workbook
Dim cs As Range, c As Range

Application.ScreenUpdating = False
Set wb = Workbooks.Open(file.PATH)

On Error Resume Next
Set cs = wb.Worksheets(targetSheet).Cells
If Err = 0 Then
　Set c = cs.Find(wItem1)
　If Not c Is Nothing Then recCell.Value = c.Offset(1).Value
　Set c = cs.Find(wItem2)
　If Not c Is Nothing Then recCell.Offset(, 1).Value = c.Offset(1).Value
End If

On Error GoTo 0
recCell.Offset(, 2).Value = file.Name
Set recCell = recCell.Offset(1)
wb.Close False
Application.ScreenUpdating = True
End Sub

fujillin · Answer

No3です

そのままを作ろうかと思ったのですが、補足を読んでも怪しいところが多々あるので、勝手に想定しました。（ほぼ前回の質問内容に沿ったものとして考えました）
https://oshiete.goo.ne.jp/qa/11972550.html

◇補足の怪しいところ（＝取り出すセルの位置が不明）
・タイトルを検索するにしても、「名称」が二か所ありユニークではないので、どうするのか不明
・仮に検索できたとしても、その列の中のどのデータを引用するのか不明
ご提示のコードの
＞Selection.Offset(RowNo + 1).Value
では、とんでもないところを参照している可能性が大と想像します。

・・・ってなわけで、以下のように勝手に解釈しました。
『指定フォルダ内にある（サブフォルダも含めて）全ての指定ファイル（=■*.xlsm 等：ただし必ずエクセルファイル）について、指定項目名（=ユニークであると仮定）を検索して、その直下のセルの値とファイル名を1行にして順にリストアップする』

・指定フォルダ、指定ファイル、検索項目名などは共通の定数としてまとめてあります。
・「再帰」がうまくできないことが、ご質問の大きな部分と思いますので、
　再帰を実現する方法の一例として考えてください。
・リストは、VBAのあるブックの最初のシートに作成されます。
　事前にシートをクリアしますのでご注意下さい。
・シート内の検索は、前回ご提示のFINDメソッドで行っていますので、完全一致では
　ありませんのでご注意。　また、シート全体から検索はしていますが、FINDの場合、
　A1セルはヒットしませんのでご注意。
（今回の補足を見ると、1行目から検索すれば充分そうな気がしますが、そのままにしてあります）
・何をなさりたいのかよくわからない部分のほとんどが、FileOUT（1ファイル分の出力）
　の処理内容ですので、その部分は適宜書き換えてみてください。
・実際は、FileOUTの部分はFolderOUT内にに組入れても良いのですが、この方がわかり
　やすそうなので分割してあります。

※ Dir関数は利用せず、FileSystemObjectのみの利用にしています。
　 また、全体の構成やロジックは、はなから作り直してあります。
※ 該当するファイルと同名のファイルが既に開いているか等のチェックは省いていますので、
　 実際の運用の際にはチェックを追加する必要があると思います。
　（現状ではエラーになります）
※ ブックを「開く/閉じる」を繰り返すので、それなりの時間がかかることが予想されます。
　 ユーザに「〇％完了」などの表示を出す方が良いと思いますが省略しました。
※ 上記をいろいろ組み込んでも良いのですが、質問者様にはわかり難くなるだけと思いましたので…

■なぜか、この文章の後にコードを記載すると「投稿エラー」（文字数オーバーではない）になるので、すみませんが二回に分けて投稿します。

めぐみん_ · Answer

No.4です。

＞'検索する項目を配列に格納
＞wItem = Array("作成日", "名称", "金額　(税込)")

が横３列に繋がっているのなら、

Dim GetCell As Range 'プロシージャーの外（一番上で宣言している場所）

~

Set GetCell = FoundCell.Resize(,3)

で

GetCell.Copy Cells(r, 1)

でいけないかね？
For~NextやSplitとかなくして。
どの道取得したい値は同行なのだから１回検索すれば後は列の指定では？

と初級レベルは思います。

めぐみん_ · Answer

No.1です。

他の疑問点としては

＞'検索する項目を配列に格納
＞wItem = Array("作成日", "名称", "金額　(税込)")

Bookによってそれほど該当する値のセル位置が変動するのでしょうか？
例えば『作成日』を基準としたら『名称』は何列目になるとかと書式の決まりがないのかなと。

あとDirをメインとサブで使っている点ってキチンと動作する物なのかな？
そう言う使い方の経験がないからちょっと不思議。

fujillin · Answer

こんばんは

前回と内容が変わっているようにみうけられます。

思うように動作しないコードだけを示されても、なさりたいことが見えないので、本当になさりたいことをキチンと言葉で説明していただいた方がよろしいように思います。

でないと、要らないところの疑問で引っかかるばかりになってしまいますから。

Qchan1962 · Answer

こんばんは、
ポイントだけですが、示されている処理に　
＞複数行取得し
のループがあるように思えません。
ターゲットのファイルを開き、キーワードで検索してそのキーワードの
 Selection.Offset(RowNo + 1).Value　1行下を取得して、次のキーワードに移行しているのではないでしょうか？

解決方法としては、色々考えられますが、取り敢えず置いといて

アドバイスとして、しっかり処理を分けて考えてみ置てください。
先ず、1ファイルを開いて検索する項目のすべてのデータを
シートに書き出すプロシージャを完成させる方が良いかも知れません。
この時、指定（定数）行から書き出すのでなく、
Cells(Rows.Count, 1).End(xlUp).Row + 1のような最終行下の新規行とすれば、このプロシージャを外部から開いたシートを対象に実行すれば、繰り返し使えます。
おそらく現在の目指す Functionかな、取り敢えず、単体で実行して直す事を勧めます。

同様に再帰的処理でしっかり条件に合うファイルのフルパスを取得する
プロシージャを書く、先のご質問のコードにあるようにシートなどに書き出し条件道理に抽出出来ているかを確認するなどしてはいかがでしょう。

両方が出来でば、アクティブなブックやシートを気を付け呼び出せば、完成かな。。

データ量が多い場合、処理速度などにも配慮が必要になると思います。
FSOよりDirを使った方が早いですし、
書き出しも都度　Cells(j, i) = FoundCell.Offset(j + 1).Value　より、
配列を使い一度にした方が早いです。
strValue(j, i) = FoundCell.Offset(j + 1).Value
Cells(r, 1).Resize(UBound(strValue) + 1, 3) = strValue

明日早い為、この辺で

めぐみん_ · Answer

何か前回の質問？で得られた回答が活かされてないように感じます。
どこを直せばと言うよりどうしてこうなったのか？不可解な点もありますし。
⇒ブックを開いたはずなのにループ内でまた（しかも何回も？）開いているのは何故なのか？とか。

ほぼ全てを書き直すにも元々どんなＳｈｅｅｔからデータを集めているのか不明ですしね。

Excel VBA でサブルーチンをループさせたいのですが

＃８

こんばんは、、＃２です。

以下、簡単な「再帰」の例として…

No3です

No.4です。

No.1です。

こんばんは

こんばんは、

何か前回の質問？で得られた回答が活かされてないように感じます。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング