Excel VBA Макросы: Как переместить эксель-файлы из одной папки в другую с перезаписью?

[GliderAlex]

Как в этой папке
D:\Папка-источник
организовать поиск файлов, у которых в начале имени есть четыре цифры, которые записаны в ячейку
Sheets("Лист1").Range("A1").Value.

Такие файлы нужно переместить в папку
D:\Папка-результат

Если в папке-результате уже есть файл с таким именем, макрос должен записать новый файл поверх имеющегося.

[Администратор]

1. Подключите библиотеку: Tools - References... - Microsoft Scripting Runtime.

2. В самом вверху модуля вставьте эти строки:
Option Explicit
Option Compare Text
Option Base 1

3. Макрос смотрит не четыре символа в начале имени файла, а ищет в начале имени все данные из ячейки.

4. Макрос сделан для виндоуса. Для мака нужно делать другой макрос.

Макрос

Sub Макрос()

    Dim fso As Scripting.FileSystemObject
    Dim папка As Scripting.Folder, файл As Scripting.File
    Dim ИмяИсхПапки As String, ИмяНовойПапки As String
    Dim НачалоИмени As String, FN_new As String
   
   
    '1. Записываем в переменные полные имена (путь + имя) папок, с которыми надо работать.
        ' Записываем в переменные, чтобы было удобнее писать и читать код.
        ' На конце полного имени папки не указывайте слеш.
    ИмяИсхПапки = "D:\Папка-источник"
    ИмяНовойПапки = "D:\Папка-результат"
   
    '2. Создание объекта, который умеет работать с папками и файлами.
    Set fso = New Scripting.FileSystemObject
   
    '3. Присваиваем папке, которую надо просмотреть, имя "папка".
        ' Далее в коде будем обращаться к этой папке по этоиму имени.
    Set папка = fso.GetFolder(ИмяИсхПапки)
   
    '4. Записываем в переменную начало имени файла, который нужно переместить в другую папку.
        ' Записываем в переменную, чтобы было удобнее читать и писать код.
    НачалоИмени = Sheets("Лист1").Range("A1").Value
   
    '5. Перемещение файлов.
    ' Просматриваем все файлы внутри папки.
    For Each файл In папка.Files
        ' Если у файла нужное начало имени.
            ' * означает ноль или любое количество любых символов.
        If файл.Name Like НачалоИмени & "*" Then
            ' Записываем в переменную новое полное имя для файла.
                ' Записываем в переменную, чтобы удобнее читать и писать код.
            FN_new = ИмяНовойПапки & "\" & файл.Name
            ' Удаление имеющегося файла.
            If fso.FileExists(FN_new) Then
                fso.DeleteFile FN_new
            End If
            ' Перемещение файла в нужную папку.
            файл.Move FN_new
        End If
    Next файл
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[GliderAlex]

Спасибо вам большое!
Все отлично заработало.