VBA　再帰　終わらない

VBAの再帰でフォルダA以下にあるファイルを全て取得しようと思っています
フォルダAの中に３つのファイルがある構造です

フォルダA-------ファイルA
・・・・・・・・ファイルB
・・・・・・・・ファイルC

以下のコードだとファイルAを永遠と取得しつづけてしまいます(無限ループ?)。
Do Whileの中のbufが更新されていないことが原因と考え、callの後にExit do を書いて、doを抜けて更新させようとすると、ファイルAしか取得せず処理が終わってします。
全てのファイルを取得できるようにしたいのですが、どのようにすればいいのでしょうか？

Sub FileSearch(path)


Dim fso As Object, folder As Variant, file As Variant, buf As String, this As Worksheet
Set fso = CreateObject("Scripting.FileSystemObject")

buf = Dir(path & "*test.xls*")

Do While buf <> ""

ReDim Preserve Sheet(bb)
ReDim Preserve Sheet_path(bb)
Sheet(bb) = buf
Sheet_path(bb) = path

bb = bb + 1
buf = Dir()

Call hikaku

Loop
 Debug.Print buf

For Each folder In fso.GetFolder(path).subFolders
   Call FileSearch(folder.path) 
Next folder

End Sub

hikaku

Sub hikaku()
If bb > 0 Then 

Do While UBound(Sheet) >= b

  Application.ScreenUpdating = False
  my = Sheet_path(b)

  Filename = Dir(my & "\" & "*test.xls*")

  Set open_file = Workbooks.Open(Filename:=my & "\" & Filename, UpdateLinks:=False)
  Set target_sheet = Workbooks(Filename).Worksheets("画面")
  Set target_sheet2 = ThisWorkbook.Worksheets("画面")
  MaxRow = target_sheet.Cells(Rows.Count, 2).End(xlUp).Row 


ReDim screen(1, 1 To MaxRow)
ReDim Number(1, 1 To MaxRow)
ReDim Lavel(1, 1 To MaxRow)
ReDim Project_type(1, 1 To MaxRow)
ReDim Control(1, 1 To MaxRow)
ReDim Events(1, 1 To MaxRow)
ReDim Sort(1, 1 To MaxRow)
ReDim Lifting(1, 1 To MaxRow)
ReDim Erea(1, 1 To MaxRow)

C = 1 
d = 1 
h = 1 


For i = 1 To UBound(screen, 1)

  For f = 1 To MaxRow
  
    If WorksheetFunction.IsNumber(target_sheet.Cells(d, 2).Value) = True And Not target_sheet.Cells(d, 2).Value = "" Then
    
    screen(i, h) = target_sheet.Cells(d, 4)
    Number(i, h) = target_sheet.Cells(d, 2)
    Lavel(i, h) = target_sheet.Cells(d, 14)
    Project_type(i, h) = target_sheet.Cells(d, 10)
    Control(i, h) = target_sheet.Cells(d, 32)
    Events(i, h) = target_sheet.Cells(d, 81)
    Sort(i, h) = target_sheet.Cells(d, 85)
    Lifting(i, h) = target_sheet.Cells(d, 87)
    
    h = h + 1
    End If
    
    If TypeName(target_sheet.Cells(d, 2).Value) = "String" Then
    Erea(i, C) = target_sheet.Cells(d, 2)
    C = C + 1
    End If
    
    d = d + 1
    
  Next f
Next i



d = MaxRow

  Do While h > 1

    If TypeName(target_sheet.Cells(d, 2).Value) = "String" Then
      C = C - 1

    ElseIf WorksheetFunction.IsNumber(target_sheet.Cells(d, 2).Value) = True Then
    
    ThisWorkbook.Worksheets(1).Range("A2:L2").Insert
    target_sheet2.Cells(2, 6) = CStr(screen(1, h - 1))
    target_sheet2.Cells(2, 2) = Workbooks(Filename).Worksheets("???").Cells(16, 25)
    target_sheet2.Cells(2, 3) = Workbooks(Filename).Worksheets("???").Cells(17, 25)
    target_sheet2.Cells(2, 5) = Number(1, h - 1)
    target_sheet2.Cells(2, 7) = CStr(Lavel(1, h - 1))
    target_sheet2.Cells(2, 8) = CStr(Project_type(1, h - 1))
    target_sheet2.Cells(2, 9) = CStr(Control(1, h - 1))
    target_sheet2.Cells(2, 10) = CStr(Events(1, h - 1))
    target_sheet2.Cells(2, 11) = Sort(1, h - 1)
    target_sheet2.Cells(2, 12) = Lifting(1, h - 1)
    target_sheet2.Cells(2, 4) = Erea(1, C - 1) 'koko
    ThisWorkbook.Worksheets(1).Range("A2:L2").ClearFormats
    h = h - 1
    
    End If

    d = d - 1

  Loop
  
  
  Workbooks(Filename).Close
  Application.ScreenUpdating = True
  b = b + 1
Loop

Else
 MsgBox "なし"
 End
End If

End Sub

kitasue

2020/09/01 08:30

Call hikaku を buf = Dir() の前に移動すると、どうなりますか？

yakumo02

2020/09/01 08:46

すみません、何も変わらないです

kitasue

2020/09/01 09:25

失礼しました。その下ですべてのサブフォルダを取得して再帰呼び出しをし、そこでまた、そのサブフォルダの下のすべてのサブフォルダを取得して．．．が続いてますね。やはりKoichiSugiyamaさんご提案の、サブフォルダをすべて取得し、そのサブフォルダの下のファイルを探すのが良いのでは。別の質問の私の回答だと、一発で取得しますがｗ

行動規範の内容に同意します

回答4件

1個下の階層を見るだけなら再帰処理じゃなくてもいいのでは？
よくわからないけど、一応直してみました。
上手くいっているかはわかりません。

ExcelVBA
1Sub FileSearch(path)
2    Dim fso As Object, folder As Variant, file As Variant, buf As String, this As Worksheet
3    Set fso = CreateObject("Scripting.FileSystemObject")
4
5    buf = Dir(path & "*test.xls*")
6    Do While buf <> ""
7        Debug.Print buf
8    
9        bb = bb + 1
10        ReDim Preserve Sheet(bb)
11        ReDim Preserve Sheet_path(bb)
12        Sheet(bb) = buf
13        Sheet_path(bb) = path
14
15        Call hikaku
16        
17        buf = Dir()
18    Loop
19    
20    For Each folder In fso.GetFolder(path).subFolders
21        Call FileSearch(folder.path)
22    Next folder
23End Sub

動作確認できるように提示してないから動作確認はしてないけど、
ブレークポイントを要所に設定し、
ステップインで1行づつ実行しながら、ローカルウィンドウで変数の中身が意図通りに
変化しているか確認して問題のある個所を探してみてください。
配列変数の中身は折りたたまれているので、
変数名の左の「+」をクリックして展開して確認してください。

他人が書いたコードを読み解くのは慣れた人でも困難だし、
毎度毎度躓いたら聞いて、他人の手を煩わすわけにもいかないので、
自分でデバッグができるよう、デバッグのコツを聞く方が有益かと思います。

投稿2020/09/01 08:49

mattuwan

総合スコア2163

yakumo02

2020/09/01 09:12

ご指摘ありがとうございますデバッグについても未熟なので勉強します

行動規範の内容に同意します

ベストアンサー

前回の質問で解決したのではないでしょうか？
少なくとも私の環境では問題ないです。
hikaku関数の中で何かやっていないですか？
Dir関数を使ってしまっているとか。

投稿2020/09/01 08:31

ttyp03

総合スコア17000

yakumo02

2020/09/01 08:46

すみません、前回はフォルダの中はファイルは1つだけの状態でやっていました。 hikakuのコードを載せましたが、配列にデータを入れて、出力するだけの処理になっています。

yakumo02

2020/09/01 09:11

すみません、 Filename = Dir(my & "\" & "*test.xls*") を Filename = Sheet(b)で解決できました

ttyp03

2020/09/01 10:05

私の回答的中じゃないの？ベストアンサーもらえなかった。。。それはともかくDirは複数同時に使うことはできないので、hikaku関数内で使った時点でFileSearchのDirはリセットされてしまいます。

kitasue

2020/09/01 10:50

> Dirは複数同時に使うことはできないそうなんですか。勉強になりました。私の心の中では、今回のベストアンサーは、ttyp03さんですｗ

ttyp03

2020/09/01 23:37

＞kitasueさんありがとうございます。報われましたｗ＞yakumo02さんあ、なんか催促したようですみませんｗ

行動規範の内容に同意します

先にサブフォルダの検索を進めて、サブフォルダが見つからない状態になってからファイルを処理する、という形で進めた方が良いのではないかと思います。

VBA
1Sub FileSearch(path)
2
3    Dim fso As Object, folder As Variant, file As Variant, buf As String, this As Worksheet
4    Set fso = CreateObject("Scripting.FileSystemObject")
5
6    For Each folder In fso.GetFolder(path).subFolders
7        Call FileSearch(folder.path) 
8    Next folder
9
10    buf = "*test.xls*"
11
12    ' フォルダ内のファイルについてループ
13    For Each File In fso.GetFolder(path).Files
14        If File.Name Like buf Then
15            '条件にあったファイルについての処理
16            'それぞれ何をしたいのかちょっと判らないので、適宜調整してください。
17            ReDim Preserve Sheet(bb)
18            ReDim Preserve Sheet_path(bb)
19            Sheet(bb) = path & "/" & File.Name
20            Sheet_path(bb) = path
21            bb = bb + 1
22
23            Call hikaku
24        End If
25    Next File
26
27End Sub