VBA循环无法从字符串数组正确运行

许多

我目前将以下代码拼凑在一起,将复制一个文件并重命名它。但是现在需要将其缩放到我存储在数组中的多个文件夹。该代码正确并复制第一个文件。但是,当它尝试打开第二个目录时会出现错误(我将扩展到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] 删除。

编辑于
0

我来说两句

0 条评论
登录 后参与评论

相关文章