Двойной цикл - циклический переход по подпапкам и файлам для консолидации

Question

Я немного застрял в завершении сценария ниже.Я дошел до этого момента, и он делает то, что мне нужно, но мне нужно немного подправить, чтобы стать идеальным.

Выполняет следующие действия: 1 выходной файл основного устройства подготовки и подготовки;2- откройте каждый файл в папке «xls» и скопируйте данные с указанного листа в конце основного выходного файла;3-финальное редактирование мастер-файла;4-мастер-файл с сохранением имени на основе входных архивов.

Мне нужна помощь, и я не смог ее исправить: я хочу, чтобы скрипт просматривал подпапки в папке 'xls' и создавал один мастердля каждой подпапки в 'xls', собирающей данные из файлов в этой подпапке, и назовите ее после подпапки.

Я понимаю, что мне нужен еще один цикл для подпапок, но я не очень хорошо разбираюсь в директориях в vba.Для этого потребуется капитальный ремонт?

Sub Joiner()

'Application.EnableCancelKey = xlDisabled

Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb  As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long


' set master workbook
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")

    With ActiveWorkbook.Sheets("Data")
        .Range("A1").FormulaR1C1 = "SysTime"
        .Range("B1").FormulaR1C1 = "Seq#"
        .Range("C1").FormulaR1C1 = "A1"
        .Range("D1").FormulaR1C1 = "F2"
        .Range("E1").FormulaR1C1 = "F3"
        .Range("F1").FormulaR1C1 = "T4"
        .Range("G1").FormulaR1C1 = "T5"
        .Range("H1").FormulaR1C1 = "T6"
        .Range("I1").FormulaR1C1 = "T7"
        .Range("J1").FormulaR1C1 = "T8"
        .Range("K1").FormulaR1C1 = "A9"
        .Range("A1:K1").Font.Bold = True
        .Range("A1:K1").Interior.ColorIndex = 19

        .Range("L1").FormulaR1C1 = "Date"
        .Range("M1").FormulaR1C1 = "Date/Seq#"

    End With


folderPath = "C:\TA\xls\" 'contains folder path

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False

FileNAME = Dir(folderPath & "*.xls*")
Do While FileNAME <> ""
    Set wb = Workbooks.Open(folderPath & FileNAME)
    'DayVar = Left(Right(wb.Name, 13), 8)

    LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
    RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)


    Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar

    wb.Close False

Exit_Loop:
    Set wb = Nothing
    FileNAME = Dir
Loop

Application.ScreenUpdating = True

    With Masterwb.Sheets("Data")
        .Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    End With

    LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row

    With ActiveWorkbook.Sheets("Data")

        .Range("L2").FormulaR1C1 = "=INT(C1)"
        .Range("M2").FormulaR1C1 = "=C12&""-""&C2"
    End With


    Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
    With ActiveSheet
        .Columns("L:L").Cells = .Columns("L:L").Cells.Value
    End With

    Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
    With ActiveSheet
        .Columns("M:M").Cells = .Columns("M:M").Cells.Value
    End With

    With Masterwb.Sheets("Data")
        .Range(Range("L2"), Range("L2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
    End With


    'Name the master output based on id
    Dim FirstName As String
    Dim InterName As String
    Dim FinalName As String
    Dim FilePath As String

    FirstName = Dir("C:TA\Input\*.cab", vbNormal)
    InterName = "Master Template " & Right(Left(FirstName, 12), 4)

    'MsgBox FirstName
    'MsgBox InterName


    FilePath = "C:\TA\output"
    ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
    FileFormat:=51, CreateBackup:=False



    '

End Sub

Спасибо за любой совет.

Answer 1

Спасибо, Патель!Я использовал ваше решение, чтобы дополнить мой текущий фрагмент VBA.Это может быть немного неуклюжим, но он делает то, что мне нужно.Спасибо.

Размещение решения ниже для пользы сообщества.

Sub MassJoiner()
'this is a version of joiner with subfolders

'Application.EnableCancelKey = xlDisabled

Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb  As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
Dim StrFile As String
Dim mFolder As String

Dim BatchCount As Long
Dim ID As String

   Set objFSO = CreateObject("Scripting.FileSystemObject")
   mFolder = "D:\TA\TEST\" ' path to change
   Set mainFolder = objFSO.GetFolder(mFolder)
   StrFile = Dir(mFolder & "*.xls*")



    BatchCount = 0

    Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"

    For Each mySubFolder In mainFolder.subfolders
     StrFile = Dir(mySubFolder & "\*.xls*")
     Do While Len(StrFile) > 0

    Set Masterwb = Workbooks("Master Template.xlsx")
    Set Targetsh = Masterwb.Sheets("Data")

    With ActiveWorkbook.Sheets("Data")
        .Range("A1").FormulaR1C1 = "SysTime"
        .Range("B1").FormulaR1C1 = "Seq#"
        .Range("C1").FormulaR1C1 = "A1"
        .Range("D1").FormulaR1C1 = "F2"
        .Range("E1").FormulaR1C1 = "F3"
        .Range("F1").FormulaR1C1 = "T4"
        .Range("G1").FormulaR1C1 = "T5"
        .Range("H1").FormulaR1C1 = "T6"
        .Range("I1").FormulaR1C1 = "T7"
        .Range("J1").FormulaR1C1 = "T8"
        .Range("K1").FormulaR1C1 = "A9"
        .Range("A1:K1").Font.Bold = True
        .Range("A1:K1").Interior.ColorIndex = 19

        .Range("L1").FormulaR1C1 = "Date"
        .Range("M1").FormulaR1C1 = "Date/Seq# pair"

    End With






'FileNAME = Dir(folderPath & "*.xls*")
'Do While FileNAME <> ""
    Set wb = Workbooks.Open(mySubFolder & "\" & StrFile)
    'DayVar = Left(Right(wb.Name, 13), 8)

    LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
    RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)


    Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar

    wb.Close False

'Exit_Loop:
'    Set wb = Nothing
'    FileNAME = Dir
'Loop

    StrFile = Dir
    Loop


    With Masterwb.Sheets("Data")
        .Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    End With

    LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row

    With ActiveWorkbook.Sheets("Data")
        .Range("M2").FormulaR1C1 = "Date/Seq# pair"
        .Range("m2").FormulaR1C1 = "=C12&""-""&C2"
    End With


    Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
    With ActiveSheet
        .Columns("L:L").Cells = .Columns("L:L").Cells.Value
    End With

    Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
    With ActiveSheet
        .Columns("M:M").Cells = .Columns("M:M").Cells.Value
    End With

    With Masterwb.Sheets("Data")
        .Range(Range("l2"), Range("l2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
    End With


    'Name the master output based on job id
    Dim FirstName As String
    Dim InterName As String
    Dim FinalName As String
    Dim FilePath As String

    FirstName = mySubFolder
    InterName = "Master Template " & Right(FirstName, 4)
    ID = Right(FirstName, 4)

    'MsgBox FirstName
    'MsgBox InterName


    FilePath = "C:\TA\output"
    ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
    FileFormat:=51, CreateBackup:=False

    ActiveWorkbook.Close False

    BatchCount = BatchCount + 1

    Application.Speech.Speak "Batch job" & BatchCount & "finalized. ID" & ID

    Workbooks.Open FileNAME:="C:\output\Master Template.xlsx"


    Next

Application.ScreenUpdating = True

End Sub

Answer 2

С помощью этого кода вы можете перечислить файлы Excel в папке и подпапках

Sub ListSubfoldersFile() ' only one level subfolders
   arow = 2
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   mFolder = "F:\Download\" ' path to change
   Set mainFolder = objFSO.GetFolder(mFolder)
   StrFile = Dir(mFolder & "*.xls*")
   Do While Len(StrFile) > 0
     Cells(arow, 1).Value = mFolder & StrFile
     arow = arow + 1
     StrFile = Dir
   Loop
   For Each mySubFolder In mainFolder.subfolders
     StrFile = Dir(mySubFolder & "\*.xls*")
     Do While Len(StrFile) > 0
        Cells(arow, 1).Value = mySubFolder & "\" & StrFile
        arow = arow + 1
        StrFile = Dir
     Loop
   Next
End Sub