完成下面的脚本我有点困惑。我达到了这一点,它完成了我需要它做的基本事情,但它需要一些调整才能变得完美。
它执行以下操作:1-pickup和prep master输出文件; 2-打开文件夹'xls'中的每个文件,并从主输出文件末尾的指定表中复制数据;主文件的3-final编辑; 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
谢谢你的任何建议。
使用此代码,您可以列出文件夹和子文件夹中的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
谢谢Patel!我使用您的解决方案来补充我当前的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