excel - 如何从最近的文件夹中粘贴 CSV 数据？

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，而是将信息粘贴到指定的工作表中。

在此先感谢您的帮助

标签： excelvba

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