Question

我对完成下面的脚本有些困惑。我到了这一点，它做了我需要做的基本事情，但是需要一些调整才能变得完美。

它执行以下操作：1-拾取并准备主输出文件； 2-打开文件夹“ xls”中的每个文件，并从主输出文件末尾的指定工作表中复制数据； 3-主文件的最终编辑； 4保存主文件，其名称基于输入档案。

我需要帮助的地方是无法解决的：我希望脚本在“ xls”文件夹中的子文件夹中循环，并为“ xls”中的每个子文件夹创建一个母版，以从该子文件夹中的文件和名称中收集数据子文件夹之后。

我知道我需要另一个子文件夹循环，但是我对vba中的dirs不太满意。这需要大修吗？

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

使用此代码，您可以在文件夹和子文件夹中列出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

Answer 2

谢谢帕特尔！我使用了您的解决方案来补充当前的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

双循环-循环浏览子文件夹和文件以进行合并

2 个答案: