Excel VBA: Комплексный макрос для добавления строк в файл при выполнении условия

[Misha21]

Здравствуйте! Подскажите пожалуйста, как можно решить следующую задачу. Некоторые моменты сделать получается, но по отдельности, на форумах столь комплексной задачи не нашел.
В одном файле есть лист, на котором в строчку представлена информация. В первой ячейке этой строчки есть номер, нужно чтобы макрос копировал эту строку, открывал файл (находится в одном месте), в котором куча таких строк с номерами, сравнивал номер скопированной строки со всеми номерами строчек в открытом файле и, если такой номер уже есть, заменял эту строку на скопированную, а если нет, чтобы строка вставлялась в конец документа (в первую незаполненную строку). Заранее спасибо за ответ!

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

Макрос находится в книге1, запускается кнопкой из "D1".
Книгу2 поместите в одну папку с книгой1.

Макрос

Sub Main_Copy()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim r As Long
   
   
    '1. Отключение монитора.
    Application.ScreenUpdating = False
   
    '2. Присваиваем имя "shSrc" активному листу.
    Set shSrc = ActiveSheet
   
    '3. Открытие файла, в который надо вставить данные.
        ' Первому листу присваиваем имя "shRes".
    Set shRes = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\Книга2.xlsx").Worksheets(1)
   
    '4. Копирование строки.
    shSrc.Rows(2).Copy
   
    '5. Поиск на листе-результате номера.
    On Error Resume Next
    r = WorksheetFunction.Match(shSrc.Range("A2").Value, shRes.Columns("A"), 0)
    On Error GoTo 0
   
    '6. Если номер не найден, то поиск последней строки.
        ' End не ищет в скрытых строках.
    If r = 0 Then
        r = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row + 1
    End If
   
    '7. Вставка скопированных данных.
    shRes.Rows(r).PasteSpecial xlPasteAll
   
    '8. Выход из режима копирования.
    Application.CutCopyMode = False
   
    '9. Сохранение и закрытие файла-результата.
    shRes.Parent.Save
    shRes.Parent.Close SaveChanges:=False
       
    '10. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '11. Сообщение, чтобы юзер понял, что макрос сделал работу.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[Misha21]

Большое спасибо, сейчас посмотрю! А возможно ли сделать так, чтобы файлы были не в одной папке? Просто файл из которого эта строка копируется, будет приходить по электронке, а файл 2 это таблица из кучи таких строк из файлов типа файла 1. Он будет лежать в одном месте, путь к этому месту известен.

[Misha21]

Если не сложно, можете, пожалуйста, закинуть сам код макроса? К сожалению файл с компа, за которым я сейчас открыть не могу

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

Книга2 может быть в любом удобном для вас месте на локальном компьютере или в локальной сети.
Полное имя (путь + имя файла) укажите здесь:
Set shRes = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\Книга2.xlsx").Worksheets(1)

Код макроса есть в ответе #1, там есть спойлер "Макрос".

[Misha21]

Огромное спасибо!!!

[Misha21]

Здравствуйте ещё раз! Появилась необходимость внести коррективы в макрос.

На данный момент макрос работает если запускать его с листа, где находится строка с нужными данными. Ситуация заключается в том, что лист с этой строкой будет скрыт, поэтому необходимо, чтобы макрос работал с любого открытого листа. Перед строкой set shSrc=ActiveSheet я написал Worksheets("Лист4").Select но это не сработало.

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

Огромное спасибо ещё раз, в остальном отлично работает!

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

Не обязательно переходить на лист, чтобы с ним что-то сделать. Поэтому "Select" не обязательно нужно использовать. В каких-то случаях действительно может понадобится использовать "Select", но обычно "Select" не нужен.

Правильно так назначить имя:
Set shSrc = Worksheets("Лист4")

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

Макрос

Sub Main_Copy()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim r As Long
   
   
    '1. Отключение монитора.
    Application.ScreenUpdating = False
   
    '2. Присваиваем имя "shSrc" листу-источнику.
    Set shSrc = Worksheets("Лист4")
   
    '3. Присваиваем имя "shRes" листу-результату.
    ' Здесь укажите имя файла-результата и имя или порядковый номер листа-результата.
    Set shRes = Workbooks("Книга2.xlsx").Worksheets(1)
   
    '4. Копирование строки.
    shSrc.Rows(2).Copy
   
    '5. Поиск на листе-результате номера.
    On Error Resume Next
    r = WorksheetFunction.Match(shSrc.Range("A2").Value, shRes.Columns("A"), 0)
    On Error GoTo 0
   
    '6. Если номер не найден, то поиск последней строки.
        ' End не ищет в скрытых строках.
    If r = 0 Then
        r = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row + 1
    End If
   
    '7. Вставка скопированных данных.
    shRes.Rows(r).PasteSpecial xlPasteAll
   
    '8. Выход из режима копирования.
    Application.CutCopyMode = False
   
    '9. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '10. Сообщение, чтобы юзер понял, что макрос сделал работу.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[Misha21]

Все работает идеально, ещё раз огромное спасибо!!!