Option Explicit
Const SrcFolderPath = "ИсхПапка"
Const ResFolderPath = "РезПапка"

Dim FileSystemObject, TextStream, Folder, SubFolder, File, FilePath
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set TextStream = FileSystemObject.OpenTextFile("log.txt",8,True)

TextStream.WriteLine "----- " & Now & " -----"

RecursiveFolderScan SrcFolderPath

MsgBox "Обработка завершена",vbInformation

'Создаём процедуру рекурсивного обхода каталога
Sub RecursiveFolderScan(FolderPath)
    'Получаем объектную модель текущего каталога
    Set Folder = FileSystemObject.GetFolder(FolderPath)
    
    'Перебираем все файлы в текущем каталоге
    For Each File in Folder.Files
        'Проверяем существование аналогичного файла в результирующем каталоге
        FilePath = FileSystemObject.BuildPath(ResFolderPath,File.Name)
        If FileSystemObject.FileExists(FilePath) Then
            'Если он существует, то производим замену
            FileSystemObject.CopyFile FilePath, FileSystemObject.BuildPath(Folder.Path,"\")
            AppendToLog "файл """ & File.Name & """ скопирован в """ & Folder.Path & """."
        End if
    Next
    
    'Перебираем все подкаталоги в каталоге
    For Each SubFolder in Folder.SubFolders
        RecursiveFolderScan(SubFolder.Path)
    Next
End Sub

Sub AppendToLog(Text)
    TextStream.WriteLine Time & ":" & Text
End Sub