Открыть последний измененный файл и скопировать в последнюю измененную книгу

Question

Я пытаюсь сделать следующее: открыть последний измененный сохраненный файл XLS (содержит только 1 лист) в папке и скопировать его рядом с последним листом другой последней измененной книги, сохраненной в другой папке.

Не уверен, понятно, но при необходимости с радостью уточню. В настоящее время я использую приведенный ниже код, который, безусловно, нуждается в улучшении.

Заранее благодарим за вашу помощь!

Sub CopyMonthlyData()

Dim sFldr As String
Dim fso As Scripting.FileSystemObject
Dim fsoFile As Scripting.File
Dim fsoFldr As Scripting.Folder
Dim dtNew As Date, sNew As String
Dim sFileName As String

Set fso = New Scripting.FileSystemObject

sFldr = "path"

Set fsoFldr = fso.GetFolder(sFldr)

For Each fsoFile In fsoFldr.Files
    If fsoFile.DateLastModified > dtNew Then
        sNew = fsoFile.Path
        sFileName = fsoFile.Name
        dtNew = fsoFile.DateLastModified
    End If
Next fsoFile

Workbooks.Open Filename:=sNew
Sheets("Sheet1").Copy Before:=Workbooks("Book2.xlsm").Sheets(1)
Windows(sFileName).Activate
ActiveWindow.Close  

Answer 1

Пожалуйста, проверьте следующий код:

Sub CopyMonthlyData()
 Dim strWbCopy As Variant, strWbDest As Variant, wbCopy As Workbook, wbDest As Workbook
 Dim strCopyFoldPath As String, strDestFoldPath As String
 strCopyFoldPath = "C:\Teste VBA Excel\Tari" 'put here the fodler path for the file to be copied
 strDestFoldPath = "C:\Teste VBA Excel\PDA"  'folder path for the destination file

 strWbCopy = getLastModifFile(strCopyFoldPath)
 strWbDest = getLastModifFile(strDestFoldPath)

 Set wbCopy = Workbooks.Open(fileName:=strWbCopy)
 Set wbDest = Workbooks.Open(fileName:=strWbDest)

 wbCopy.Sheets(1).Copy Before:=wbDest.Sheets(1)

 wbCopy.Close
End Sub

Function getLastModifFile(sFldr As String) As String
 Dim fso As New Scripting.FileSystemObject
 Dim fsoFile As Scripting.File, fsoFldr As Scripting.folder
 Dim dtNew As Date, sNew As String, sFileName As String

 Set fsoFldr = fso.GetFolder(sFldr)

 For Each fsoFile In fsoFldr.Files
    If fsoFile.DateLastModified > dtNew Then
        sNew = fsoFile.path
        sFileName = fsoFile.Name
        dtNew = fsoFile.DateLastModified
    End If
 Next fsoFile
 getLastModifFile = sNew
End Function

Вы должны позаботиться только об изменении strCopyFoldPath и strCopyFoldPath соответствующими путями. И убедитесь, что все файлы в двух обработанных папках являются файлами .xls ... В противном случае функция также должна сравнивать расширения файлов.

Следующая функция не требует ссылки:

Function getLastModifFile(sFldr As String) As String
 Dim fso As Object, fsoFile As Object, fsoFldr As Object
 Set fso = CreateObject("Scripting.FileSystemObject")

 Dim dtNew As Date, sNew As String, sFileName As String

 Set fsoFldr = fso.GetFolder(sFldr)

 For Each fsoFile In fsoFldr.Files
    If fsoFile.DateLastModified > dtNew Then
        sNew = fsoFile.path
        sFileName = fsoFile.Name
        dtNew = fsoFile.DateLastModified
    End If
 Next fsoFile
 getLastModifFile = sNew
End Function