查找最新的文件并复制到另一个工作簿

Question

我正在尝试将这两个宏结合起来：

宏1:这会找到一个文件并将工作表复制到另一个工作簿。我需要找到前缀为"的最新文件；"汽车分配"；，只有当我手动键入完整的文件名时，这才有效。

Sub cpy()
Dim x As Workbook
Dim y As Workbook

'## Open both workbooks first:
Set x = Workbooks.Open("\DesktopARC DevNew folderCar Assignments 11-16-2020.xlsx")
Set y = Workbooks.Open("\DesktopARC Devarcgoat.xlsm")

'Now, copy what you want from x:
x.Sheets("Portfolio Assignments").Range("A1:U920").Copy

'Now, paste to y worksheet:
y.Sheets("Portfolio Assignments").Range("A1").PasteSpecial

'Close x:
x.Close
MsgBox ("Completed")
End Sub

宏2：这会在目录中查找最新的文件，但是，它不考虑前缀为"车辆分配"的文件。

Option Explicit

Sub NewestFile()

Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date

MyPath = "\DesktopARC DevNew folder"
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""
MyFile = Dir(MyPath & "*.xlsx", vbNormal)

If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If

Do While Len(MyFile) > 0

LMD = FileDateTime(MyPath & MyFile)

If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
Workbooks.Open MyPath & LatestFile

End Sub

我正试图将最新的Excel文件复制到"；\Desktop \ARC Dev\New folder"具有名称"的目录；汽车分配"；然后将该表复制到一个名为arcgoat的工作簿中；\Desktop \ARC Dev\arcgoat.xlsm"目录

Answer 1

我已经根据您的喜好修改了代码，

Sub NewestFile()
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim x As Workbook 'content copied to this work book
Dim y As Workbook 'y latest work book,where the content copied from
Set x = ActiveWorkbook
'MyPath = ActiveWorkbook.Path & "files" ' x workbook_location/files - Search the latest file y  here
MyPath = "C:UserssiddharthDesktopARC DevNew folder" 'search the y workbook here
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""
MyFile = Dir(MyPath & "Car Assignments*.xlsx", vbNormal)
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
Set y = Workbooks.Open(MyPath & LatestFile)
y.Sheets("Portfolio Assignments").Range("A1:U920").Copy
Application.DisplayAlerts = False 'Error msg pop disable
x.Sheets("Portfolio Assignments").Range("A1").PasteSpecial
y.Close
Application.DisplayAlerts = True ' Error msg enabled back
MsgBox ("Content Copied")
End Sub