How to copy the most current file from one folder to another

[BIFanatic]

I have uploaded the file for you here https://www.udrop.com/7cr/CopyRecentFile.xlsm or you could also plug the below code into your module.

Option Explicit


Dim FileNames()             As Variant
Dim FSO                     As Object
Dim FileCounter             As Long
Const FinalFileName         As String = "BiFanatic" 'Change this name to your choice


Sub MoveRecentFile()


    Dim FD                      As FileDialog
    Dim IsSourceFolSelected     As Boolean
    Dim IsTargetFolSelected     As Boolean
    Dim SourceFolderPath        As String
    Dim RecentDate              As Date
    Dim RecentFileName          As String
    Dim x                       As Long
    Dim Fil                     As Object
    Dim TargetFolderPath        As String


    Set FD = Application.FileDialog(msoFileDialogFolderPicker)


    Do While IsSourceFolSelected = False Or IsTargetFolSelected = False 'Checks if both source and target folders are selected


        If IsSourceFolSelected = False Then
            FD.Title = "Select source folder"
            IsSourceFolSelected = FD.Show
            If Not IsSourceFolSelected = False Then
                SourceFolderPath = FD.SelectedItems(1)
                IsSourceFolSelected = True
            End If
        End If


        If IsTargetFolSelected = False Then
            FD.Title = "Select target folder"
            IsTargetFolSelected = FD.Show
            If Not IsTargetFolSelected = False Then
                TargetFolderPath = FD.SelectedItems(1)
                IsTargetFolSelected = True
            End If
        End If


    Loop


    Set FSO = CreateObject("Scripting.FileSystemObject")
    FileCounter = 1


    Call LoopOverFoldersAndSubFolders(SourceFolderPath, False) 'Change it to true if you want to loop over subfolders in a folder


    RecentDate = FileNames(2, 1)
    
    'check for the most recent date
    
    For x = 1 To UBound(FileNames, 2)
        If FileNames(2, x) > RecentDate Then
            RecentDate = FileNames(2, x)
            RecentFileName = FileNames(1, x)
        End If
    Next x


    Set Fil = FSO.GetFile(RecentFileName)
    Fil.Copy TargetFolderPath & "\" & FinalFileName & "." & FSO.GetExtensionName(Fil.Name)


    Set FSO = Nothing
    Erase FileNames


End Sub


Private Sub LoopOverFoldersAndSubFolders(SourceFolderPath As String, Optional LoopOverSubFolder As Boolean = False)


    Dim SourceFolder            As Object
    Dim SubFol                  As Object
    Dim Fil                     As Object


    Set SourceFolder = FSO.GetFolder(SourceFolderPath)


    For Each Fil In SourceFolder.Files
        ReDim Preserve FileNames(1 To 2, 1 To FileCounter)


        FileNames(1, FileCounter) = Fil.Path
        FileNames(2, FileCounter) = Fil.DateLastModified


        FileCounter = FileCounter + 1
    Next Fil


    If LoopOverSubFolder = True Then
        For Each SubFol In SourceFolder.SubFolders
            Call LoopOverFoldersAndSubFolders(SubFol.Path, True)
        Next SubFol
    End If


End Sub