如何导入以日期为名称的外部文件

Question

我想使用VBA将外部文件中的数据导入或复制粘贴到当前Excel文件中。但是，外部文件中包含上个月的日期。例如，外部文件名为"Report_20221128"。每个月，这个外部文件日期可能不同，不一定是当月的28号。

这是我到目前为止所做的。

Sub Report_Run()

Dim wb As Workbook
Dim file As Variant
Dim wbrow As Long, wbrow2 As Long, wbrow3 As Long
Day = Application.WorksheetFunction.EoMonth(Now(), "-1")
Set wb = Workbooks("Run Report " & VBA.Format(LDay, "ddmmyyyy") & ".xlsb")

wb.Worksheets("DD").Activate
wbrow3 = Cells(Rows.Count, "A").End(xlUp).Row

file = Dir(Environ("userprofile") & "DesktopReportsReport_" & Format(Date, "yyyymmdd") & ".xlsx")
End Sub

但是，代码无法读取这一行

file = Dir(Environ("userprofile") & "DesktopReportsReport_" & Format(Date, "yyyymmdd") & ".xlsx")

因此，我应该如何设置代码，使其能够读取包含前一个月的任何日期的外部文件?

Answer 1

从匹配模式的文件中导入工作表

Sub ImportLastMonth()

' Constants
Const SRC_PATH_RIGHT As String = "DesktopReports"
Const SRC_FILE_LEFT As String = "Report_"
Const SRC_FILE_RIGHT As String = ".xlsx"
Const SRC_WORKSHEET_ID As Variant = "Sheet1" ' adjust! Name or Index

' Source Path
Dim sPathLeft As String: sPathLeft = Environ("USERPROFILE")
Dim sPath As String: sPath = sPathLeft & SRC_PATH_RIGHT
Dim sFolderName As String: sFolderName = Dir(sPath, vbDirectory)
If Len(sFolderName) = 0 Then
MsgBox "The path '" & sPath & "' was not found.", vbCritical
Exit Sub
End If

' Source File
Dim sPatternLeft As String: sPatternLeft = SRC_FILE_LEFT _
& Format(CDate(Application.EoMonth(Now, "-1")), "yyyymm")
Dim sPattern As String: sPattern = sPatternLeft & "*" & SRC_FILE_RIGHT
Dim sFileName As String: sFileName = Dir(sPath & sPattern)
If Len(sFileName) = 0 Then
MsgBox "No files matching the pattern '" & sPattern & "' in '" _
& sPath & "' found.", vbCritical
Exit Sub
End If

' Day

Dim DayStart As Long: DayStart = Len(sPatternLeft) + 1

Dim DayNumString As String, DayNum As Long, NewDayNum As Long

Do While Len(sFileName) > 0
DayNumString = Mid(sFileName, DayStart, 2)
If IsNumeric(DayNumString) Then
NewDayNum = CLng(DayNumString)
If NewDayNum > DayNum Then DayNum = NewDayNum
End If
Debug.Print sFileName, DayNumString, NewDayNum, DayNum
sFileName = Dir
Loop

If DayNum = 0 Then
MsgBox "No file found.", vbCritical
Exit Sub
End If

Application.ScreenUpdating = False

' Source
Dim sFilePath As String
sFilePath = sPath & sPatternLeft & Format(DayNum, "0#") & SRC_FILE_RIGHT
Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath, True, True)
Dim sws As Worksheet: Set sws = swb.Sheets(SRC_WORKSHEET_ID)

' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code

' Copy
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count) ' last
swb.Close SaveChanges:=False

Application.ScreenUpdating = True

' Inform.
MsgBox "Last month's final report imported.", vbInformation

End Sub

Answer 2

使用FileSystemObject和Like

Option Explicit
Sub Report_Run()

Dim wb As Workbook, TargetWB As Workbook
Dim DT As Date
Dim wbrow As Long, wbrow2 As Long, wbrow3 As Long
Dim FSO As Object, oFolder As Object, oFile As Object

Set FSO = CreateObject("scripting.filesystemobject")
' > This needs to be the folder you expect to contain your report
Set oFolder = FSO.getfolder("C:UserscameronDocuments")

' > Date is already a VBA function, you have to use a different variable
DT = Application.WorksheetFunction.EoMonth(Date, "-1")
' > I have this set to "ThisWorkbook" as it's fewer things to worry about, but feel free to change this. _
What is LDay? |/ you don't have this variable declared
Set wb = ThisWorkbook 'workbooks("Run Report " & VBA.Format(LDay, "ddmmyyyy") & ".xlsb")

' > Avoid using activate
wbrow3 = wb.Worksheets("DD").Cells(Rows.Count, "A").End(xlUp).Row

' > Check each file to see if they're from last month
For Each oFile In oFolder.Files
If oFile.Name Like "Report_" & Format(DT, "yyyymm") & "*" & ".xlsb" Then 'Report name with wildcard for day
Set TargetWB = Workbooks.Open(oFile.Path)
Exit For
End If
Next oFile

' > You now have the report book from last month open and saved to "TargetWB"
End Sub