VBA: открыть все папки и подпапки и выполнить действие

Question

Мне понадобится небольшая помощь, я не эксперт по VBA, я «собрал» этот код, объединив миллионы кодов и полезных строк от других, но, насколько мне известно, он функционирует.

Что на самом деле делает (должен делать) этот код, принимает заданное расширение c .file и преобразует их в файлы .txt, но также изменяет формат даты и сокращает столбцы из исходного файла. Ничего особенного, ничего нового. Но проблема, с которой я столкнулся, заключается в том, что когда я выбираю указанную папку c, в которой больше папок и вложенных папок, макрос выполняет только преобразование / копирование на второй уровень (папка A или B) сабвуферов. Я пропускаю всегда последний уровень, как в этом примере вниз (дополнительные папки).

Уровень 1) Основная папка с дополнительными подпрограммами внутри :

Уровень 2) Папка >> Уровень 3) с дополнительными папками

Уровень 2) B папка >> Level3) с дополнительными папками

Что и как мне нужно изменить часть кода, чтобы он работал правильно? Я также хочу точно скопировать структуру и вид оригинальных папок. Итак, сделайте макрос для моих папок и файлов, но также сохраните их в их исходных папках после преобразования и преобразования.

Надеюсь, я был достаточно понятен ... вот мой код:

Sub Button1_Click()

Dim FileSystem As Object
Dim HostFolder As String
Dim answer As String
Dim fs, strFolderPath, oFolder
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' *** Folder with files to define (path) ***
 HostFolder = GetSourceFolder()

 If HostFolder = "" Then
    MsgBox "No folder selected! Run Macro again!", vbOKOnly + vbExclamation, "Important!"
    Exit Sub
 End If

Set fs = CreateObject("Scripting.FileSystemObject")
strFolderPath = HostFolder

Set oFolder = fs.GetFolder(HostFolder)
 If Dir(HostFolder & "\*.*") = "" And oFolder.SubFolders.Count = 0 Then

' *** If folder is empty/full message ***
' * Folder is Empty *
   MsgBox "Folder is empty!", vbOKOnly + vbInformation, "Information!"

   Exit Sub

 Else
 ' * Folder isn't empty *
   answer = MsgBox("Folder not empty! Proceed with Macro?", vbYesNo + vbInformation + 
vbDefaultButton1, "Information!")
   If answer = vbNo Then Exit Sub
 End If

Set fs = Nothing
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Dim targetFolder As String
targetFolder = GetTargetFolder()
Dim newFolder As String

If targetFolder = "" Then
    MsgBox "No folder selected! Run macro again!", vbOKOnly + vbInformation, "Information!"
    Exit Sub
 End If
newFolder = InputBox("Create new folder!")
targetFolder = targetFolder & "\" & newFolder
If newFolder = vbNullString Then
    Exit Sub
ElseIf FileSystem.FolderExists(targetFolder) Then
    MsgBox "Folder already exists!", vbOKOnly + vbExclamation, "Information!"
    Exit Sub
End If

DoFolder FileSystem.GetFolder(HostFolder), targetFolder
MsgBox "Macro finished!", vbOKOnly + vbInformation, "Information!"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
Sub DoFolder(Folder, targetFolder As String)
Dim Workbook
Dim SubFolder

For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder, targetFolder
Next
Dim File
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each File In Folder.Files

    ' *** Operate on each file ***
    Set Workbook = Workbooks.Open(File)

    ' *** Sort, filter and rename each file/column ***
    If Workbook.FileFormat = -4158 Then
        Set Workbook = Workbook.ActiveSheet
            Workbook.Columns("D:E").EntireColumn.Delete
            Workbook.Columns("E").EntireColumn.Delete
            Workbook.Columns("R:T").EntireColumn.Delete
            Workbook.Rows("1").Delete

            Range("A1:Q1").Value = Array("Date/Time", "P0 [mbar]", "P1 [mbar]", "PS160 [mbar]", "P220 
  [mbar]", _
            "Q1 [ppb]", "Q2 [ppb]", "Q3 [ppb]", "Q4 [ppb]", _
            "T11 [°C]", "T21 [°C]", "T31 [°C]", "T12 [°C]", "T22 [°C]", "T32 [°C]", "T01 [°C]", "T02 
  [°C]")

            Workbook.Columns("A").NumberFormat = "dd.mm.yyyy hh:mm"

    ' *** Preparing new folder for filtered/sorted files ***
        Dim FLDR_NAME As String
        FLDR_NAME = Mid(Application.ActiveWorkbook.Path, InStrRev(Application.ActiveWorkbook.Path, 
    "\") + 1)
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")

        FLDR_NAME = targetFolder & "\" & FLDR_NAME
        If Not fso.FolderExists(targetFolder) Then
               fso.CreateFolder (targetFolder)
        End If

        If Not fso.FolderExists(FLDR_NAME) Then
               fso.CreateFolder (FLDR_NAME)
        End If

    ' *** Save As Converter_Converted as separate file ***
        Dim newFileName As String
        newFileName = FLDR_NAME & "\" & Workbook.Name & ".txt"
        Application.DisplayAlerts = False
        Workbook.SaveAs FileName:=newFileName

    ' *** Close and SaveAs ***
        Application.ActiveWorkbook.Close
    End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Function GetSourceFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select Source Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetSourceFolder = sItem
Set fldr = Nothing
 End Function

 Function GetTargetFolder() As String
Dim filePath As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select Output Folder"
    .AllowMultiSelect = False
    .InitialFileName = filePath
    '.InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetTargetFolder = sItem
Set fldr = Nothing
End Function
Public Function change_commas(ByVal myValue As Variant) As String

Dim str_temp As String

str_temp = CStr(myValue)
change_commas = Replace(str_temp, ".", ",")

End Function