サブフォルダ名の取得

Question

昨日？今朝質問をさせていただき、無事にファイルの移動をすることができました。
リンク内容
今朝のコードを元にサブフォルダ名を取得したいのですが、If文を抜けてしまいます。
このあとに、先の質問のようにサブフォルダ数をカウントし、サブフォルダ名を取得したいのです。
やりたいことはサブフォルダ内にファイルがあれば開くという処理をしたいのです。
サブフォルダは現在はTestなので104つくらいあります。
ご教示よろしくお願いします。

Dim FSO As Object, fn As Variant, FolderNames() As String, cnt As Long
Set FSO = CreateObject("Scripting.FileSystemObject")

    If shTab.Range("G3") = "" And shTab.Range("I3") = "" Then
        FilePath = wb.Path & "\エントリーシート\"
        ReDim FolderNames(FSO.GetFolder(FilePath).SubFolders.Count)
        For Each fn In FSO.GetFolder(FilePath).SubFolders
            If FSO.GetParentFolderName(fn.Name) <> "" Then
                cnt = cnt + 1
                FolderNames(cnt) = FSO.ParentFolderName(fn.Name)
            End If
        Next fn

Answer 1

再帰を利用してファイル名を取得します。
ファイルを検索する
※「Excel 2007以降でファイルを検索する」以降を参考に。

Comments

[Naoko_Coco]

ありがとうございます。
If shTab.Range("G3") = "" And shTab.Range("I3") = "" Then
FilePath = wb.Path & "\エントリーシート"
For Each fn In FSO.GetFolder(FilePath).SubFolders
File = fn.Path

File = Dir(File & "*.xlsx")
Do While File <> ""

'開くExcelファイル
FilePath = fn.Path & "\" & File
Set wbEntry = Workbooks.Open(FilePath)
er = wbEntry.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
r = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
i = r
For j = 17 To er
If wbEntry.ActiveSheet.Cells(j, 1) = "○" Then

'エントリーページ
sh.Cells(i, 2).Value = wbEntry.ActiveSheet.Cells(j, 12).Value

'項番
sh.Cells(i, 1) = wbEntry.ActiveSheet.Range("B10")

'会社名
corp = wbEntry.ActiveSheet.Range("C4").Value
sh.Cells(i, 3) = corp

i = i + 1
End If
Next j
'Bookを閉じる
Workbooks(File).Close savechanges:=False

File = Dir()
Loop
Next fn
で、無事にサブフォルダー名を取得しBookもOpenでき、思った通りのものができました！

Answer 2

以下のように修正し、Excelファイル（フルパス）で取得してはどうでしょうか。

Dim FSobjfile as Object
For Each fn In FSO.GetFolder(FilePath).SubFolders
  For Each FSobjfile In fn.Files
    If FSO.GetExtensionName(FSobjfile.Name) = "xlsx" Then
      cnt = cnt + 1
      ReDim Preserve FileNames(cnt)
      FileNames(cnt) = fn.Name & "\" & FSobjfile.Name
    End If
  Next FSobjfile
Next fn
'ReDim FolderNames(FSO.GetFolder(FilePath).SubFolders.Count)
'  For Each fn In FSO.GetFolder(FilePath).SubFolders
'    If FSO.GetParentFolderName(fn.Name) <> "" Then
'      cnt = cnt + 1
'    FolderNames(cnt) = FSO.ParentFolderName(fn.Name)
'  End If
'Next fn

Comments

[Naoko_Coco]

返信が遅くなり申し訳ございません。
ReDim Preserve FileNames(cnt)で変数が定義されてないのエラーが出ます。
なんでだろ？