Страницы: 1
RSS
Excel VBA Копирование вставка данных из одной папки с файлами в другую папку с файлами
 
Добрый день!

Есть задача.

1) Имеется в наличии 2 папки: называются Papka1 и Papkа2
2) Список файлов Papka1:
Апельсин Д-00082
Помидор (СЦ)_Уд-0000000087
Яблоко (СЦ)_Пр_231

3) Список  файлов Papka2:
Tr27 Апельсин
помидор UZ-96
Яблоко АА7

4) Имеется таблица соотнесения ячеек файлов из Papka1 и Papka2, это соотнесение статично, выглядит так:
Papka1, файл Апельсин Д-00082     Papka2, файл  Tr27 Апельсин
                                 Ячейка С2 = Ячейка D2
                                 Ячейка С4 = Ячейка D3
                                 Ячейка С5 = Ячейка D4
                                 Ячейка С9 = Ячейка D5
Для файлов содержащих в название слово "Помидор" и "помидор" действует такое же правило копирования\вставки из Papka1 в Papka2.
5) Количество файлов в Papka 1 равно количеству файлов в Papka2,
6) Данные из файла Яблоко в Papka1 копируем и вставляем в файл Апельсин Papka2. Имена файлов немного отличаются.
Т.е. из одной формы установленного образца делаем другую форму установленного образца.

Файлов несколько сотен на самом деле.

7) Какой код необходим для того чтобы копировать ячейки из Papka1 в Papka2?
 
Код
Sub KopirovanieIVstavka()
Dim s As String, p As String, MyFiles As String, MyFiles2 As String, MyVal As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False

MyFiles = "C:\Users\Users\Desktop\Papka1\"
s = Dir(MyFiles & "*.xls")
Do While s <> ""
    With Workbooks.Open(MyFiles & s)

' Как оформить поиск по именам файлов в Papka2 ? 
x = Left(.Dir(Myfiles, InStr(1, Dir(MyFiles, ",") - 1)

    ' Address to copy file
        Set MyVal = Dir(MyFiles2& "*.xls").Find(x)
        If Not MyVal Is Nothing Then

        ' To copy file            To insert file
       Dir(MyFiles).Range("С2") = Dir(MyFiles2).Range("D2")
        Dir(MyFiles).Range("С4") = Dir(MyFiles2).Range("D3")
        Dir(MyFiles).Range("С5") = Dir(MyFiles2).Range("D4")
        Dir(MyFiles).Range("С9") = Dir(MyFiles2).Range("D5")
        .Close SaveChanges:=True
        End If
    End With
    s = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Прошу строго не судить, по образованию не программист))

Код не работает.
Прошу помочь с кодом.
Изменено: Spec - 02.09.2020 06:48:25
 
Посмотрите в сторону FileSystemObject
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Наверх