Здравствуйте! Подскажите пожалуйста, как можно решить следующую задачу. Некоторые моменты сделать получается, но по отдельности, на форумах столь комплексной задачи не нашел.
В одном файле есть лист, на котором в строчку представлена информация. В первой ячейке этой строчки есть номер, нужно чтобы макрос копировал эту строку, открывал файл (находится в одном месте), в котором куча таких строк с номерами, сравнивал номер скопированной строки со всеми номерами строчек в открытом файле и, если такой номер уже есть, заменял эту строку на скопированную, а если нет, чтобы строка вставлялась в конец документа (в первую незаполненную строку). Заранее спасибо за ответ!
Макрос находится в книге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
Большое спасибо, сейчас посмотрю! А возможно ли сделать так, чтобы файлы были не в одной папке? Просто файл из которого эта строка копируется, будет приходить по электронке, а файл 2 это таблица из кучи таких строк из файлов типа файла 1. Он будет лежать в одном месте, путь к этому месту известен.
Если не сложно, можете, пожалуйста, закинуть сам код макроса? К сожалению файл с компа, за которым я сейчас открыть не могу
Книга2 может быть в любом удобном для вас месте на локальном компьютере или в локальной сети.
Полное имя (путь + имя файла) укажите здесь:
Set shRes = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\Книга2.xlsx").Worksheets(1)
Код макроса есть в ответе #1, там есть спойлер "Макрос".
Огромное спасибо!!!
Здравствуйте ещё раз! Появилась необходимость внести коррективы в макрос.
На данный момент макрос работает если запускать его с листа, где находится строка с нужными данными. Ситуация заключается в том, что лист с этой строкой будет скрыт, поэтому необходимо, чтобы макрос работал с любого открытого листа. Перед строкой 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
Все работает идеально, ещё раз огромное спасибо!!!