Всем привет.
Есть 2 файла.
Как перенести данные из файла "прайс-лист" (назовём его "источник") в файл "менеджеры" (назовём его "результат") при определенных условиях?
Если в файле "прайс-лист" на листе "нужный лист" I10=Подшипники, то скопировать ячейки в файл "менеджеры" на лист "ПдШ" данные следующим образом:
E10 в B2, H10 в C2, I10 в D2, K10 в E2, M10 в J2, N10 в M2.
Файл "источник" в идеале должен быть закрыт.
Запуск происходит с файла "результат".
Макрос должен просматривать не только ячейку I10, а весь столбец I.
Причем, если Вы обратили внимание, в колонке I могут быть и пустые значения, но в колонке Е не может быть пустого значения, поэтому имеет смысл использовать ячейку E при считывании диапазона.
[вложение удалено администратором]
Макрос:
Sub Procedure1()
' В константах нужно указать номера строки, с которых начинаются данные (именно данные, а не шапка).
' Начало на листе-источнике.
Const lngNachalo_Source As Long = 10
' Начало на листе-результате.
Const lngNachalo_Res As Long = 2
Dim bkSource As Excel.Workbook, shSource As Excel.Worksheet
Dim shRes As Excel.Worksheet
Dim lngKonec_Source As Long, lngKonec_Res As Long
Dim i As Long
' Отключение обновления монитора, чтобы
'1) не видеть открытие файла-источника;
'2) чтобы макрос быстрее работал.
Application.ScreenUpdating = False
' Присвоение листу-результату VBA-имени "shRes".
' С помощью этого имени можно будет обращаться к листу-результату в коде.
Set shRes = Worksheets("ПдШ")
' Открытие файла-источника.
' Присвоение файлу-источнику VBA-имени "bkSource".
' С помощью этого имени можно будет обращаться к файлу-источнику в коде.
' ReadOnly:=True - чтобы меньше было непредсказуемых событий.
Set bkSource = Workbooks.Open(Filename:="C:\Users\User\Desktop\прайс\Источник.xlsx", ReadOnly:=True)
' Присвоение листу-источнику VBA-имени "shSource".
' С помощью этого имени можно будет обращаться к листу-источнику в коде.
Set shSource = bkSource.Worksheets("нужный_лист")
' Определение последней строки на листе-источнике.
lngKonec_Source = shSource.UsedRange.Row + shSource.UsedRange.Rows.Count - 1
' Удаление старых данных из листа-результата.
' Определение последней строки на листе-результате.
' Дальше последняя строка будет скорректирована.
lngKonec_Res = shRes.UsedRange.Row + shRes.UsedRange.Rows.Count - 1
' Удаление, если есть данные.
If lngKonec_Res >= lngNachalo_Res Then
shRes.Rows(lngNachalo_Res & ":" & lngKonec_Res).Delete
End If
' Корректировка последней строки листа-результате.
' Переменная lngKonec_Res будет использоваться для перемещения по листу-результату.
lngKonec_Res = lngNachalo_Res
' Движение по строкам на листе-листочнике.
For i = lngNachalo_Source To lngKonec_Source Step 1
' Просмотр, что находится в нужной ячейке на листе-источнике.
' Если в ячейке не подшипники.
If shSource.Cells(i, "I").Value <> "Подшипники" Then
' Переход к следующей строке на листе-источнике.
GoTo metka
End If
' Если оказались здесь, значит в ячейке слово "Подшипники".
' Функциональная часть.
shRes.Cells(lngKonec_Res, "B").Value = shSource.Cells(i, "E").Value
shRes.Cells(lngKonec_Res, "C").Value = shSource.Cells(i, "H").Value
shRes.Cells(lngKonec_Res, "D").Value = shSource.Cells(i, "I").Value
shRes.Cells(lngKonec_Res, "E").Value = shSource.Cells(i, "K").Value
shRes.Cells(lngKonec_Res, "J").Value = shSource.Cells(i, "M").Value
shRes.Cells(lngKonec_Res, "M").Value = shSource.Cells(i, "N").Value
' Корректировка переменной, чтобы перейти к следующей строке на листе-результате.
lngKonec_Res = lngKonec_Res + 1
metka:
Next i
' Закрытие файла-источника.
bkSource.Close SaveChanges:=False
' Включение обновления монитора.
Application.ScreenUpdating = True
' Сообщение, чтобы было понятно, что макрос сделал работу.
MsgBox "Макрос завершил работу.", vbInformation
End Sub