我目前将以下代码拼凑在一起,将复制一个文件并重命名它。但是现在需要将其缩放到我存储在数组中的多个文件夹。该代码正确并复制第一个文件。但是,当它尝试打开第二个目录时会出现错误(我将扩展到30个以上的目录)。似乎循环不是从顶部开始,而是从中间开始。我该如何解决。
PS我出于安全原因只能使用示例变量名称和路径
Sub Coxxxxxxauto()
Dim MyPath As String
Dim MyPath2 As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim xWB As Workbook
Dim DateStamp As String
Dim FilePath1 As String
Dim Path1 As String
Dim vJc As Variant
Dim vItem As Variant
Dim Jc1 As String
Dim Jc2 As String
Jc1 = "\\C:\Documents\Newsletters\Eg1****2018"
Jc2 = "\\C:\Documents\Newsletters\Eg2****2018"
vJc = Array(Jc1, Jc2)
DateStamp = "US_" & Format(Date - 1, "YYYY-MM-DD")
For Each vItem In vJc
'Make sure that the path ends in a backslash
If Right(vItem, 1) <> "\" Then MyPath = vItem & "\"
'Get the first Excel file from the folder
MyFile = Dir(MyPath & "*.csv", vbNormal)
'If no files were found, exit the sub
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
'Loop through each Excel file in the folder
Do While Len(MyFile) > 0
'Assign the date/time of the current file to a variable
LMD = FileDateTime(MyPath & MyFile)
'If the date/time of the current file is greater than the latest
'recorded date, assign its filename and date/time to variables
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
'Get the next Excel file from the folder
MyFile = Dir
Loop
'Open the latest file
Workbooks.Open MyPath & LatestFile # Loop starts here on second run
Application.DisplayAlerts = False
Sheets(1).Select
Sheets(1).Copy
Application.DisplayAlerts = False
'On Error GoTo errHandler
ActiveWorkbook.SaveAs Filename:=vItem & "\" & Right(vItem, Len(vItem) - InStrRev(vItem, "_")) & "_" &
DateStamp, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.ScreenUpdating = False
For Each xWB In Application.Workbooks
If Not (xWB Is Application.ThisWorkbook) Then
xWB.Close
End If
Next
Application.ScreenUpdating = True
'MsgBox "Files Published. Check for adjustments.", vbOKOnly, "Spot-On: Alert "
Next vItem
errHandler:
MsgBox "Existing file Found", vbCritical, "Wait a Minute...We've been here before"
For Each xWB In Application.Workbooks
If Not (xWB Is Application.ThisWorkbook) Then
xWB.Close
End If
Next
End Sub
希望我很清楚
请尝试以下操作,我简化了一些代码
您的变量“ LatestDate”是在子程序的开头声明的,并且从未重置过,因此,在循环到达第二个数组位置时,先前的“ LastDate”持续存在,并且如果在第二个文件夹中没有文件具有更高的filedatetime,则该持续存在与之前保存的相同,使得好像跳过了第一个循环。
Sub Coxxxxxxauto()
Application.ScreenUpdating = False
Dim DateStamp As String
DateStamp = "US_" & Format(Date - 1, "YYYY-MM-DD")
Dim Jc1 As String
Dim Jc2 As String
Jc1 = "\\C:\Documents\Newsletters\Eg1****2018"
Jc2 = "\\C:\Documents\Newsletters\Eg2****2018"
Dim vJc As Variant
vJc = Array(Jc1, Jc2)
Dim vItem As Variant
For Each vItem In vJc
'Make sure that the path ends in a backslash
Dim MyPath As String: MyPath = vItem
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'Get the first Excel file from the folder
Dim MyFile As String
MyFile = Dir(MyPath & "*.xml", vbArchive)
'If no files were found, exit the sub
If Len(MyFile) = 0 Then: MsgBox "No files were found...", vbExclamation: GoTo NextFolder
'Loop through each Excel file in the folder
Dim LatestFile As String: LatestFile = ""
Dim LatestDate As Date: LatestDate = 0
Do While Len(MyFile) > 0
'Assign the date/time of the current file to a variable
Dim LMD As Date: LMD = FileDateTime(MyPath & MyFile)
'If the date/time of the current file is greater than the latest
'recorded date, assign its filename and date/time to variables
If LMD > LatestDate Then LatestFile = MyFile: LatestDate = LMD
'Get the next Excel file from the folder
MyFile = Dir
Loop
'Copy
FileCopy MyPath & LatestFile, vItem & "\" & Right(vItem, Len(vItem) - InStrRev(vItem, "_")) & "_" & DateStamp & ".csv"
Dim xWB As Workbook
For Each xWB In Application.Workbooks
If xWB.Name <> ThisWorkbook.Name Then xWB.Close True
Next xWB
Application.ScreenUpdating = True
NextFolder:
Next vItem
End Sub
本文收集自互联网,转载请注明来源。
如有侵权,请联系 [email protected] 删除。
我来说两句