Question

我们有一个模型，可以每天生成CSV格式的结果，并每次将这些文件保存到一个新文件夹中。 csv文件始终具有相同的名称，只有子文件夹名称会更改（文件夹名称的一部分包含日期）。

我想创建一个vba脚本，该脚本将在所有子文件夹中搜索最新的csv文件，将其复制并粘贴到excel文件中（覆盖前几天的数据）。

我希望建立这样的东西：

'Sub OpenLatestFile()

'Declare the variables
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date

'Specify the path to the folder
MyPath = "C:\Users\Desktop\EmgMgmt"

'Make sure that the path ends in a backslash
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

'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
    End Sub

这只会在指定的文件夹中打开最新的csv。鉴于每天都会生成一个新文件夹，因此我想编写代码以搜索所有子文件夹中的最新csv文件。我也不希望它只是打开csv而是在指定工作表中显示信息。

预先感谢您的帮助

Answer 1

我经常以以下方式使用ADODB

我为文件创建一个“内存中”记录集

Option Explicit
Function rsFiles() As ADODB.Recordset
    ' Defines In Memory Recordset for the files
    ' In Memory Recordset
    ' https://www.databasejournal.com/features/msaccess/article.php/3846361/Create-In-Memory-ADO-Recordsets.htm

    Dim rsData As ADODB.Recordset

    Set rsData = New ADODB.Recordset

    rsData.Fields.Append "Filename", adVarChar, 256
    rsData.Fields.Append "Extension", adVarChar, 8
    rsData.Fields.Append "Path", adVarChar, 256
    rsData.Fields.Append "DateCreated", adDate
    rsData.Fields.Append "DateLastModified", adDate
    Set rsFiles = rsData

End Function

然后我用目录结构中的所有文件填充此记录集

Sub RecursiveFolder(ByRef fld As Scripting.Folder, ByRef rsFiles As ADODB.Recordset, _
    ByRef includeSubFolders As Boolean)

    Dim FSO As Scripting.FileSystemObject   ' Needed because I wanted the extension in a separate field
    Dim sngFile As Scripting.File
    Dim subFld As Scripting.Folder

    'Loop through each file in the folder
    Set FSO = New Scripting.FileSystemObject
    For Each sngFile In fld.Files
        rsFiles.AddNew
        rsFiles.Fields("FileName") = sngFile.Name
        rsFiles.Fields("Path") = sngFile.Path
        rsFiles.Fields("Extension") = FSO.GetExtensionName(sngFile.Path & Application.PathSeparator & sngFile.Name)
        rsFiles.Fields("DateCreated") = sngFile.DateCreated
        rsFiles.Fields("DateLastModified") = sngFile.DateLastModified
        rsFiles.Update
    Next sngFile

    'Loop through files in the subfolders
    If includeSubFolders Then
        For Each subFld In fld.SubFolders
            Call RecursiveFolder(subFld, rsFiles, True)
        Next subFld
    End If

End Sub

这是一种使用方法

Option Explicit

' Example How to use RecursiveFolder and InMemory Recordset
' Set a reference to Microsoft Scripting Runtime and
' Micrososft Acitve Data Objects by using
' Tools > References in the Visual Basic Editor (Alt+F11)

Sub GetAFile()

    Dim FSO As Scripting.FileSystemObject
    Dim fld As Scripting.Folder
    Dim myPath As String
    Dim aFiles As ADODB.Recordset
    Dim errMsg As String

    On Error GoTo EH

    'Specify the path to the folder
    myPath = Range("A1").Value2

    'Create an instance of the FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")

    'Make sure the folder exists
    If Not FSO.FolderExists(myPath) Then
        errMsg = "No such folder exists!"
        GoTo EH
    End If

    'Get the folder
    Set fld = FSO.GetFolder(myPath)

    'Get the file names from the specified folder and its subfolders into an array
    Set aFiles = rsFiles
    aFiles.Open , , adOpenDynamic
    RecursiveFolder fld, aFiles, True

    ' Example - Filter the recordset by Extension and sort by DateCreated
    Dim sFilter As String
    ' Get the filter condition

    sFilter = ThisWorkbook.Sheets(1).Range("A2").Value2
    If Len(sFilter) > 0 Then
        aFiles.Filter = "Extension Like '" & sFilter & "'"
    Else
        sFilter = "CSV"
        aFiles.Filter = "Extension Like '" & sFilter & "'"
    End If
    aFiles.Sort = "DateCreated DESC"

    ' Print the name of the file withe the latest creation date
    If aFiles.RecordCount > 0 Then
        Range("A3").value2 = aFiles.Fields("Path")
        Debug.Print aFiles.Fields("Path"), aFiles.Fields("Filename"), aFiles.Fields("DateLastModified")
    Else
        Range("A3").value2 ="No file found"
        Debug.Print "No file found"
    End If


ExitSub:
    Exit Sub

    'Error handling
EH:
    If Len(errMsg) > 0 Then
        MsgBox errMsg, vbExclamation
        GoTo ExitSub
    Else
        MsgBox "Error " & Err.Number & ":  " & Err.Description
        Resume ExitSub
    End If

End Sub

如何从最新文件夹粘贴CSV数据？

1 个答案: