Копировать данные из указанных c файлов из подпапок

Question

Я пытаюсь извлечь только несколько столбцов из 1 листа из указанного c файла из всех вложенных папок. Однако я сталкиваюсь с двумя проблемами:

1. мой код не go в каждую подпапку для поиска файлов
2. , даже если он ищет файл, он копирует данные правильно, но мне нужно пропустить дату, которая может быть извлечена из имени подпапки или имени файла. В коде я пытаюсь скопировать дату из имени файла, но по какой-то причине она не вставляет дату, хотя она правильно идентифицирует часть имени файла.

Sub loopAllSubFolderSelectStartDirectory()

'Another Macro must call LoopAllSubFolders Macro to start to procedure
Call LoopAllSubFolders(ThisWorkbook.Path & "\")

End Sub

Sub LoopAllSubFolders(ByVal folderPath As String)

Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(ThisWorkbook.Path & "\*Inputs Transform Sheet*")

While Len(fileName) <> 0

    If Left(fileName, 1) <> "." Then

        fullFilePath = folderPath & fileName

        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
 If fileName <> ThisWorkbook.Name Then
 Workbooks.Open fullFilePath
 With Workbooks(fileName).Sheets("Inputs_Transformed")
 .Range("A3:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1)
 ThisWorkbook.Sheets("Sheet1").Range("E" & .Cells(.Rows.Count, 5).End(xlUp).Row & ":E" & .Cells(.Rows.Count, 1).End(xlUp).Row).Offset(1) = Right(Workbooks(fileName).Name, 13)
  End With
 Application.CutCopyMode = False
 Workbooks(fileName).Close True
 End If
 End If

 End If

    fileName = Dir()

Wend

For i = 0 To numFolders - 1

    LoopAllSubFolders folders(i)

Next i

End Sub