VBA 查找包含特定日期的相关文件，代码第一次工作但重新运行时它找不到具有相同日期的新文件

问题描述

我编写/复制了以下在 VBA 中执行一些操作的代码。它会执行一些操作，例如查找文件名中具有特定日期的所有文件，然后将这些文件保存在另一个指定的文件夹中。

我的问题是，当我第一次运行下面的代码时，它运行良好，但稍后说另一个文件进来了，我想将此文件与先前在第一次运行时找到的文件一起添加到集合对象中。即使新文件在我重新运行时具有相同的日期，但不幸的是它没有找到新文件。

但是，如果我删除以前创建的文件夹并从头开始运行它，它将找到所有相关文件。只有当我一天多次运行 sub 时，它才找不到附加文件，我不明白为什么，就像 recursivefilesearch 没有刷新文件夹而只是使用以前找到的文件。

知道我在这里做错了什么，需要更新以在我重新运行宏时让 recursivefilesearch 找到所有相关文件吗？

Option Explicit

Sub Merge_Data()

    Application.StatusBar = "Finding today's files"
    Application.ScreenUpdating = False
    Application.displayAlerts = False
    
    Dim FilePath As String
    FilePath = "folder\"
    
    ' Ask user what date they would like to merge the files for
    Dim dateString As String,TheDate As Date
    Dim valid As Boolean: valid = True
    Dim Input_Box_Msg As String

    Input_Box_Msg = "What Date would you like to merge the files for? " & vbNewLine & "Please enter date in format mm/dd/yyyy: "
    
    Do
      dateString = InputBox(Input_Box_Msg)
    
      If IsDate(dateString) Then
        TheDate = DateValue(dateString)
        valid = True
      Else
        MsgBox "Invalid date. Please enter date in format mm/dd/yyyy:"
        valid = False
      End If
    Loop Until valid = True
    
    'Edit_1: Based on Comment
    ' Obtain current date in format yyyymmdd
    Dim Current_Date,Current_Date_1 As String
    
    Current_Date = Format(TheDate,"yyyymmdd")
    Current_Date_1 = Format(TheDate,"yyyy_mm_dd")
    
    ' Find all files in folder that contain prevIoUsly input date by the user
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Dim objRegExp As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    
    ' Regex object with prevIoUsly input date by the user
    objRegExp.Pattern = Current_Date
    objRegExp.IgnoreCase = True

    Dim colFiles As Collection
    Set colFiles = New Collection
    Dim f As Variant
    
    ' Recursively search through folders for files that match today's date
    RecursiveFileSearch FilePath,objRegExp,colFiles,objFSO
    
    Dim Combined_Path As String
    Combined_Path = "new_folder\"
    Combined_Path = Combined_Path & Current_Date & "\"
    
    Dim Path As String
    Dim Folder As String
    Dim FileFormatNum As Long
    Dim FileName As String
    
    ' .xlsx extension number
    FileFormatNum = 51

    Path = Combined_Path
    Folder = Dir(Path,vbDirectory)
 
    ' Create New folder to store today's files
    If Folder = vbNullString Then
        VBA.FileSystem.MkDir (Path)
    End If
    
    Dim Full_File_Path As String
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim File_Type_1 As String
    Application.StatusBar = "Saving today's files in new folder"
    
    ' Save Files that match criteria in new folder in .xlsx format
    For Each f In colFiles
        Workbooks.Open f
        FileName = ActiveWorkbook.Name
        MsgBox FileName
        File_Type_1 = FSO.GetExtensionName(FileName)
        If File_Type_1 = "xls" Then
            FileName = FileName & "x"
            Full_File_Path = Path & FileName
            ActiveWorkbook.SaveAs FileName:=Full_File_Path,FileFormat:=FileFormatNum,CreateBackup:=False
            ActiveWorkbook.Close
            File_Type_1 = ""
            FileName = ""
            Full_File_Path = ""
        ElseIf File_Type_1 = "xlsx" Then
            If Left(FileName,11) = "Merged_File" Then Exit For
        Else
            Full_File_Path = Path & FileName
            ActiveWorkbook.Close
            Kill Full_File_Path
            ActiveWorkbook.SaveAs FileName:=Full_File_Path,CreateBackup:=False
            ActiveWorkbook.Close
            FileName = ""
            Full_File_Path = ""
            File_Type_1 = ""
        End If
    Next
    
    FilePath = ""
    Current_Date = ""
    Current_Date_1 = ""
    Set f = nothing
    Set colFiles = New Collection
    Set FSO = nothing
    Set objFSO = nothing
    Set objRegExp = nothing
    RecursiveFileSearch FilePath,objFSO

End Sub

Sub RecursiveFileSearch(ByVal targetFolder As String,ByRef objRegExp As Object,_
                ByRef matchedFiles As Collection,ByRef objFSO As Object)

    Dim objFolder As Object
    Dim objFile As Object
    Dim objSubfolder As Object
    Dim objSubFolders As Object

    'Get the folder object associated with the target directory
    Set objFolder = objFSO.GetFolder(targetFolder)

    'Loop through the files current folder
    For Each objFile In objFolder.Files
        If objRegExp.test(objFile) Then
            matchedFiles.Add (objFile)
        End If
    Next

    'Loop through the each of the sub folders recursively
    Set objSubFolders = objFolder.Subfolders
    For Each objSubfolder In objSubFolders
        RecursiveFileSearch objSubfolder,matchedFiles,objFSO
    Next

    'Garbage Collection
    Set objFolder = nothing
    Set objFile = nothing
    Set objSubFolders = nothing
    Set objSubfolder = nothing

End Sub

Function FileExists(ByVal FiletoTest As String) As Boolean
   FileExists = (Dir(FiletoTest) <> "")
End Function

Function StripNumber(stdText As String)
    Dim str As String,i As Integer
    'strips the number from a longer text string
     stdText = Trim(stdText)
     For i = 1 To Len(stdText)
     If Not IsNumeric(Mid(stdText,i,1)) Then
     str = str & Mid(stdText,1)
     End If
     Next i
     StripNumber = str ' * 1
End Function

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

file-search vba