Наученный горьким опытом, постановок прошлых вопросов, попытаюсь объяснить что мне требуется. Есть большой прайс лист. Книга - состоящая из двух листов. На первом листе сам прайс, создаваемый вручную - с характеристиками каждого товара. Второй лист технический - куда скидываем все что находим по тем или иным товарам. Признак сравнения между ними - это первый столбец в каждом листе, всей книги. На втором листе - может быть много строк наименований товаров, но опять же признак сравнения - это фраза в первой ячейке первого столбца.
Очень нужен макрос сравнения/вставки. Т.е. требуется чтобы со второго листа он взял всю строку, сравнив ее лишь по первой ячейке первого столбца, с первым листом/первым столбцом. При нахождении полного совпадения по слову - в первой ячейке первого столбца (учитываем только слово, то что есть после него - не важно, например после пробела что-то в скобках, или еще слова, т.е. первое слово найдено, во втором листе первого столбца, и оно такое же есть на первом листе в первом столбце), требуется раздвинуть и прямо под найденным таким же значением фразы в первом листе вставить всю строку со второго листа - желательно заменив цвет всей скопированной строки на зеленый. Если находит такую же вторую строку, раздвигает опять и вставляет ниже - на первом листе следующую позицию.
Наученный горьким опытом, постановок прошлых вопросов, попытаюсь объяснить что мне требуется. Есть большой прайс лист. Книга - состоящая из двух листов. На первом листе сам прайс, создаваемый вручную - с характеристиками каждого товара. Второй лист технический - куда скидываем все что находим по тем или иным товарам. Признак сравнения между ними - это первый столбец в каждом листе, всей книги. На втором листе - может быть много строк наименований товаров, но опять же признак сравнения - это фраза в первой ячейке первого столбца.
Очень нужен макрос сравнения/вставки. Т.е. требуется чтобы со второго листа он взял всю строку, сравнив ее лишь по первой ячейке первого столбца, с первым листом/первым столбцом. При нахождении полного совпадения по слову - в первой ячейке первого столбца (учитываем только слово, то что есть после него - не важно, например после пробела что-то в скобках, или еще слова, т.е. первое слово найдено, во втором листе первого столбца, и оно такое же есть на первом листе в первом столбце), требуется раздвинуть и прямо под найденным таким же значением фразы в первом листе вставить всю строку со второго листа - желательно заменив цвет всей скопированной строки на зеленый. Если находит такую же вторую строку, раздвигает опять и вставляет ниже - на первом листе следующую позицию.
Sub Test() Dim Sh As Worksheet, Sh1 As Worksheet, key As String, A() Set C_is = CreateObject("scripting.dictionary") C_is.CompareMode = 1 Set Sh = ThisWorkbook.Worksheets("Разное") LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row LastColl = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column + 1 dx = Sh.Range("A1:B" & LastRow) For n = 2 To UBound(dx) key = dx(n, 1) If key <> "" Then key = Split(key, " ")(0) If C_is.Exists(key) Then A = C_is.Item(key) paralast = UBound(A) + 1 ReDim Preserve A(paralast) A(paralast) = n C_is.Item(key) = A Else C_is.Item(key) = Array(n) End If End If Next Set Sh1 = ThisWorkbook.Worksheets("Основной прайс") LastRow1 = Sh1.Cells(Sh1.Rows.Count, 1).End(xlUp).Row dx1 = Sh1.Range("A1:B" & LastRow1) Application.ScreenUpdating = False For n = UBound(dx1) To 2 Step -1 key = dx1(n, 1) If key <> "" Then key = Split(key, " ")(0) If C_is.Exists(key) Then A = C_is.Item(key) rw = n + 1 For i = 0 To UBound(A) Sh1.Rows(rw).Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove Sh.Rows(A(i)).Copy Sh1.Range("A" & rw) Sh1.Range("A" & rw).Resize(1, LastColl).Interior.Color = 5287936 Next End If End If Next Application.ScreenUpdating = True End Sub
Sub Test() Dim Sh As Worksheet, Sh1 As Worksheet, key As String, A() Set C_is = CreateObject("scripting.dictionary") C_is.CompareMode = 1 Set Sh = ThisWorkbook.Worksheets("Разное") LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row LastColl = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column + 1 dx = Sh.Range("A1:B" & LastRow) For n = 2 To UBound(dx) key = dx(n, 1) If key <> "" Then key = Split(key, " ")(0) If C_is.Exists(key) Then A = C_is.Item(key) paralast = UBound(A) + 1 ReDim Preserve A(paralast) A(paralast) = n C_is.Item(key) = A Else C_is.Item(key) = Array(n) End If End If Next Set Sh1 = ThisWorkbook.Worksheets("Основной прайс") LastRow1 = Sh1.Cells(Sh1.Rows.Count, 1).End(xlUp).Row dx1 = Sh1.Range("A1:B" & LastRow1) Application.ScreenUpdating = False For n = UBound(dx1) To 2 Step -1 key = dx1(n, 1) If key <> "" Then key = Split(key, " ")(0) If C_is.Exists(key) Then A = C_is.Item(key) rw = n + 1 For i = 0 To UBound(A) Sh1.Rows(rw).Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove Sh.Rows(A(i)).Copy Sh1.Range("A" & rw) Sh1.Range("A" & rw).Resize(1, LastColl).Interior.Color = 5287936 Next End If End If Next Application.ScreenUpdating = True End Sub
Function НомерПоследнейСтроки(Страница As Worksheet) As LongPtr НомерПоследнейСтроки = Страница.UsedRange.Row + Страница.UsedRange.Rows.Count - 1 End Function
Sub ОбработкаДополнительныхТоваров() Dim ОбрабатываемаяЯчейка As Range, ПерваяЯчейка As Range, ПерваяЯчейкаПоиска As Range, НайденноеЗначение As Range Dim Идентификатор As String Dim ПозицияПробела As Byte
Set ПерваяЯчейка = Sheets("Разное").Cells(2, 1) Set ПерваяЯчейкаПоиска = Sheets("Основной прайс").Cells(3, 1)
For Each ОбрабатываемаяЯчейка In Sheets("Разное").Range(ПерваяЯчейка, Sheets("Разное").Cells(НомерПоследнейСтроки(Sheets("Разное")), 1)) If Not IsEmpty(ОбрабатываемаяЯчейка.Offset(0, 1).Value) Then ПозицияПробела = InStr(ОбрабатываемаяЯчейка.Value, " ") If ПозицияПробела > 0 Then Идентификатор = Left(ОбрабатываемаяЯчейка.Value, ПозицияПробела - 1) Else Идентификатор = ОбрабатываемаяЯчейка.Value End If Set НайденноеЗначение = Sheets("Основной прайс").Range(ПерваяЯчейкаПоиска, Sheets("Основной прайс").Cells(НомерПоследнейСтроки(Sheets("Основной прайс")), 1)).Find(Идентификатор & "*", LookIn:=xlValues, LookAt:=xlWhole) If Not НайденноеЗначение Is Nothing Then Sheets("Основной прайс").Rows(НайденноеЗначение.Row + 1).Insert Sheets("Разное").Range(Sheets("Разное").Cells(ОбрабатываемаяЯчейка.Row, 1), Sheets("Разное").Cells(ОбрабатываемаяЯчейка.Row, 58)).Copy Sheets("Основной прайс").Cells(НайденноеЗначение.Row + 1, 1) Sheets("Основной прайс").Range(Sheets("Основной прайс").Cells(НайденноеЗначение.Row + 1, 1), Sheets("Основной прайс").Cells(НайденноеЗначение.Row + 1, 58)).Interior.Color = vbGreen End If End If Next ОбрабатываемаяЯчейка End Sub
[/vba]
[vba]
Код
Function НомерПоследнейСтроки(Страница As Worksheet) As LongPtr НомерПоследнейСтроки = Страница.UsedRange.Row + Страница.UsedRange.Rows.Count - 1 End Function
Sub ОбработкаДополнительныхТоваров() Dim ОбрабатываемаяЯчейка As Range, ПерваяЯчейка As Range, ПерваяЯчейкаПоиска As Range, НайденноеЗначение As Range Dim Идентификатор As String Dim ПозицияПробела As Byte
Set ПерваяЯчейка = Sheets("Разное").Cells(2, 1) Set ПерваяЯчейкаПоиска = Sheets("Основной прайс").Cells(3, 1)
For Each ОбрабатываемаяЯчейка In Sheets("Разное").Range(ПерваяЯчейка, Sheets("Разное").Cells(НомерПоследнейСтроки(Sheets("Разное")), 1)) If Not IsEmpty(ОбрабатываемаяЯчейка.Offset(0, 1).Value) Then ПозицияПробела = InStr(ОбрабатываемаяЯчейка.Value, " ") If ПозицияПробела > 0 Then Идентификатор = Left(ОбрабатываемаяЯчейка.Value, ПозицияПробела - 1) Else Идентификатор = ОбрабатываемаяЯчейка.Value End If Set НайденноеЗначение = Sheets("Основной прайс").Range(ПерваяЯчейкаПоиска, Sheets("Основной прайс").Cells(НомерПоследнейСтроки(Sheets("Основной прайс")), 1)).Find(Идентификатор & "*", LookIn:=xlValues, LookAt:=xlWhole) If Not НайденноеЗначение Is Nothing Then Sheets("Основной прайс").Rows(НайденноеЗначение.Row + 1).Insert Sheets("Разное").Range(Sheets("Разное").Cells(ОбрабатываемаяЯчейка.Row, 1), Sheets("Разное").Cells(ОбрабатываемаяЯчейка.Row, 58)).Copy Sheets("Основной прайс").Cells(НайденноеЗначение.Row + 1, 1) Sheets("Основной прайс").Range(Sheets("Основной прайс").Cells(НайденноеЗначение.Row + 1, 1), Sheets("Основной прайс").Cells(НайденноеЗначение.Row + 1, 58)).Interior.Color = vbGreen End If End If Next ОбрабатываемаяЯчейка End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
