vba 再帰呼び出し 初期化

Question

以下のコードは、あるフォルダのサブフォルダを取得して、サブフォルダの中にあるファイルを全て取得します。
その後、取得したファイル名をエクセルに貼り付けます。
貼り付け時は.a=55 Cells(a, 1)として、aの値を更新して55行目から行を1行づつずらして56行、57行と、貼り付けたいと思っています。
しかし、サブフォルダを取得するときに再帰を使っているので、毎回aの値が55に初期化させてしまい、55行目にしか貼り付けることができません。
aの値を更新して貼り付けたいです。
ご教授お願いします。

Sub FileSearch(path As String)

Dim FSO As Object, Folder As Variant, File As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")

'サブフォルダ取得
For Each Folder In FSO.GetFolder(path).SubFolders
   Call FileSearch(Folder.path)
Next Folder


file_path = "C:\Users******\Desktop****"
book = Dir(file_path & "*テスト.xls*")
 

a = 55
'エクセルファイル取得
For Each File In FSO.GetFolder(path).Files

  If File.Name = Dir(path & "*テスト.xls*") Then
  'ここで貼り付け
  Workbooks(book).Worksheets("Sheet1").Cells(a, 1) = File.Name

  End If
Next File

End Sub

Answer 1

Option Explicit

'Microsoft Scripting Runtimeを参照設定して使用すること
Dim mFSO As FileSystemObject
Dim mRng As Range

Sub test()
    Dim strFolder As String
    Dim ix As Long
    
    'フォルダー選択指定
    If GetFolderPath(strFolder) = False Then Exit Sub
    '書き出しセル初期値
    Set mRng = Workbooks(Workbooks.Count).Worksheets(1).Range("A55")
    'FSO取得
    Set mFSO = New FileSystemObject
    
    'ファイルフルパス一覧取得
    GetFileList mFSO.GetFolder(strFolder), ix
End Sub

'フォルダの選択
Private Function GetFolderPath(ByRef sPath As String) As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Title = "フォルダの選択"
        If .Show = True Then
            sPath = .SelectedItems(1)
            GetFolderPath = True
        End If
    End With
End Function

'ファイル一覧取得（サブフォルダ含む）
Private Function GetFileList(ByVal objFolder As Folder, ByRef i As Long) As Boolean
    Dim fo As Folder
    Dim fi As File
    
    For Each fo In objFolder.SubFolders
        GetFileList fo, i
    Next
        
    For Each fi In objFolder.Files
        If mFSO.GetExtensionName(fi) Like "xls?" Then
            i = i + 1
            With mRng(i, 1)
                .Worksheet.Hyperlinks.Add Anchor:=.Cells, _
                                          Address:=fi.Path, _
                                          TextToDisplay:=fi.Name
            End With
        End If
    Next
End Function

僕なら
Private Function GetFileList(ByVal sPath As String, ByRef i As Long) As Boolean
のように、セルの相対位置の値を、
次の呼び出すプロシージャに受け渡していきますかね。

あと、単にファイル名を一覧にしても、どこのフォルダーにあるかわからないので、
ハイパーリンクを挿入して、見つけたファイルを直接開けるようにしてみました。

それから、FSOを何度も取得したり開放したりすることは無駄かなと、
モジュールレベルで使えるように変数を宣言してみました。
もちろんセルの位置もモジュールレベルで宣言してもいいかと思います。

あと、同じ値を得るために同じDir関数を使うのも無駄です。
書いてるのは一言だけど、VBAで書いてないので見えないけど、
誰かが書いたプログラムを呼び出していることになるので、
同じ値を使うときは、変数に値を1回保持して、それを使いまわすといいと思います。

あと、せっかくFSOを使っているので、どうせならFSOをフル活用してもいいかなと思いました。
Dir関数の方が処理は速いらしいですが、コードを書くのに
FSOの方が使い便利がいいので。

※簡単な動作確認はしてますが、
もれなくリストアップされるかは確認してませんので、
間違いがないか自己責任でお願いします。

※コードに不具合があったので修正しました。

Comments

[yakumo02]

ご丁寧にご回答ありがとございます。
こちらの書き方も勉強していこうと思いますが、radames1000さんとのコメントの方も見ていただけないでしょうか？

[yakumo02]

すみません、以上は解決しました。

[yakumo02]

とてもご丁寧な対応ありがとうございました！

Answer 2

こんな感じではどうでしょうか。

Option Explicit
'
Private pstrMyPath As String
Private plngLayer As Long
Private plngRowCount As Long
'
Function Test_Sample_Miniature()
    pstrMyPath = "C:\test"
    plngRowCount = 54
    plngLayer = 0
    Call 自己参照(pstrMyPath, plngLayer)
End Function
'
'***********************************************
'    ＜自己参照＞
'***********************************************
Function 自己参照(ByVal MyPath As String, ByVal intLayer As Integer)
    Dim fs As Object
    Dim MyFolders As Object
    Dim MyFiles As Object
    Dim fsObj As Object
    Dim MyObj As Object
    intLayer = intLayer + 1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fsObj = fs.GetFolder(MyPath)
    For Each MyObj In fsObj.SubFolders
        plngRowCount = plngRowCount + 1
        Cells(plngRowCount, intLayer + 0) = MyObj.Name
        Cells(plngRowCount, intLayer + 1) = MyObj.DateCreated
        Cells(plngRowCount, intLayer + 2) = MyObj.DateLastAccessed
        Cells(plngRowCount, intLayer + 3) = MyObj.DateLastModified
        Call 自己参照(MyObj.Path, intLayer)
    Next
    For Each MyObj In fsObj.Files
        plngRowCount = plngRowCount + 1
        Cells(plngRowCount, intLayer + 0) = MyObj.Name
        Cells(plngRowCount, intLayer + 1) = MyObj.DateCreated
        Cells(plngRowCount, intLayer + 2) = MyObj.DateLastAccessed
        Cells(plngRowCount, intLayer + 3) = MyObj.DateLastModified
    Next
    Set fs = Nothing
End Function

(参考資料)
https://teratail.com/questions/281147

Comments

[yakumo02]

ご丁寧にご回答ありがとございます。
こちらの書き方も勉強していこうと思いますが、radames1000さんとのコメントの方も見ていただけないでしょうか？

[yakumo02]

すみません、以上は解決しました。

[yakumo02]

とてもご丁寧な対応ありがとうございました！

Answer 3

前々回の質問でhatena19さんが紹介してくださった
サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）：Excel VBA｜即効テクニック｜Excel VBAを学ぶならmoug
を最後まできちんと読めばわかりますよ。

---

下記が参照URLに記載の内容の一部です。

Sub Test()
　　cnt = 0
　　Call Sample3("C:\Work")
End Sub

cntをここで初期化し、Sample3に進んでいます。
この例ではcnt=54とすれば次から1を足されていくのでご希望のものになると思います。

Comments

[yakumo02]

失礼しました
誤記です

[yakumo02]

すみません、やはりa=55をどこに記述すればいいのかが分かりません
whileの中に記述しても当然毎回初期化されます

[yakumo02]

編集ありがとうございます
以下のようにしたのですが、プロシージャが違うのか何も書き込まれません

Sub sample()
a = 55
Call FileSearch("C:\Users\xxxxxx\Documents\Document\xxxxx")
End Sub

Sub FileSearch(path As String)

Dim FSO As Object, Folder As Variant, File As Variant, buf As String

Set FSO = CreateObject("Scripting.FileSystemObject")
buf = Dir(path & "*???.xls*")

_
For Each Folder In FSO.GetFolder(path).SubFolders
Call FileSearch(Folder.path)
Next Folder

Do While buf <> ""

a = a + 1
ThisWorkbook.Worksheets("Sheet2").Cells(a, 1) = buf
buf = Dir()

Loop
End Sub

[yakumo02]

すみません、グローバル変数を宣言していませんでした

[yakumo02]

とてもご丁寧な対応ありがとうございました！