Добрый день! Есть два файла. В первом БД по автомобилям, во втором некие запчасти, например дворники или брызговики. На каждую модель автомобиля может приходиться несколько запчастей заменителей. Как с помощью формулы или макроса настроить вывод всех запчастей и заменителей в разные столбцы. Допустим, есть Ауди А6, во второй БД есть для Ауди А6 5 видов дворников с разными артикулами. Нужно, чтобы в первой таблице напротив Ауди А6 в соседних столбцах подтянулись все 5 дворников. Файл с примером в приложении
Добрый день! Есть два файла. В первом БД по автомобилям, во втором некие запчасти, например дворники или брызговики. На каждую модель автомобиля может приходиться несколько запчастей заменителей. Как с помощью формулы или макроса настроить вывод всех запчастей и заменителей в разные столбцы. Допустим, есть Ауди А6, во второй БД есть для Ауди А6 5 видов дворников с разными артикулами. Нужно, чтобы в первой таблице напротив Ауди А6 в соседних столбцах подтянулись все 5 дворников. Файл с примером в приложенииCoshVSR
Спасибо, вроде то!! Такой вопрос. Что делать, если необходимо, чтобы данная формула работала на большом объеме данных - 20-30тыс строк в БД по тачкам и 5-7тыс артикулов по запчастям. Может быть как-то оптимизировать можно? Или вообще проще через Access?
Спасибо, вроде то!! Такой вопрос. Что делать, если необходимо, чтобы данная формула работала на большом объеме данных - 20-30тыс строк в БД по тачкам и 5-7тыс артикулов по запчастям. Может быть как-то оптимизировать можно? Или вообще проще через Access?CoshVSR
Dim arrArt() For r = 2 To shA.Cells(Rows.Count, 1).End(xlUp).Row ReDim arrArt(0) sA = shA.Cells(r, 1).Value '1 это столбец в котором берем название авто на листе "Авто" With shZ.Range("a1:a" & shZ.Cells(Rows.Count, 1).End(xlUp).Row) ' столбец А на листе "запчасти" где ищем Set c = .Find(sA, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do arrArt(UBound(arrArt)) = c.Offset(0, 2).Value 'артикул запчасти берем со сдвигом на 2 столбца А-С ReDim Preserve arrArt(UBound(arrArt) + 1) Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With If UBound(arrArt) > 0 Then shA.Cells(r, 1).Offset(0, 1).Resize(1, UBound(arrArt) + 1) = arrArt 'артикулы запчасти вносим со сдвигом на один столбец от авто А-В Next r End Sub
[/vba] upd. Откорректировал по замечанию ниже, файл перевложил [p.s.]Конструктивная критика приветствуется, тренируюсь с массивами VBA
Добрый день. Вариант макроса[vba]
Код
Dim arrArt() For r = 2 To shA.Cells(Rows.Count, 1).End(xlUp).Row ReDim arrArt(0) sA = shA.Cells(r, 1).Value '1 это столбец в котором берем название авто на листе "Авто" With shZ.Range("a1:a" & shZ.Cells(Rows.Count, 1).End(xlUp).Row) ' столбец А на листе "запчасти" где ищем Set c = .Find(sA, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do arrArt(UBound(arrArt)) = c.Offset(0, 2).Value 'артикул запчасти берем со сдвигом на 2 столбца А-С ReDim Preserve arrArt(UBound(arrArt) + 1) Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With If UBound(arrArt) > 0 Then shA.Cells(r, 1).Offset(0, 1).Resize(1, UBound(arrArt) + 1) = arrArt 'артикулы запчасти вносим со сдвигом на один столбец от авто А-В Next r End Sub
[/vba] upd. Откорректировал по замечанию ниже, файл перевложил [p.s.]Конструктивная критика приветствуется, тренируюсь с массивами VBAsboy
Уточните пожалуйста, в коде, какие параметры отвечают за следующее: 1. Номер столбца, в котором ищется название авто. 2. Номер столбца, с которого макрос начинает "разносить" значения артикулов 3. Номер столбца в запчастях, в котором макрос ищет соответствие названию авто из п.1
Уточните пожалуйста, в коде, какие параметры отвечают за следующее: 1. Номер столбца, в котором ищется название авто. 2. Номер столбца, с которого макрос начинает "разносить" значения артикулов 3. Номер столбца в запчастях, в котором макрос ищет соответствие названию авто из п.1CoshVSR
Скажите, а можно как-то к этому макросу прикрутить индикацию статуса выполнения? Просто он "пилит" уже полчаса, при этом Excel не висит, нагрузка на процессор идёт...
Скажите, а можно как-то к этому макросу прикрутить индикацию статуса выполнения? Просто он "пилит" уже полчаса, при этом Excel не висит, нагрузка на процессор идёт...CoshVSR
В итоге макрос обработал объем таблицы 24000*60 за час. Я так понимаю, тут все упирается исключительно в мощность ПК? Никак оптимизировать нельзя?
В итоге макрос обработал объем таблицы 24000*60 за час. Я так понимаю, тут все упирается исключительно в мощность ПК? Никак оптимизировать нельзя?CoshVSR
Sub test() Application.ScreenUpdating = False Dim shA As Worksheet, shZ As Worksheet, dic As Object Dim arrZ, temp$() Dim i&, lr&, dItem$
Set shA = Sheets("Авто") Set shZ = Sheets("запчасти") 'Будем записывать все артикулы в словарь (авто - ключ, массив артикулов - значение) Set dic = CreateObject("scripting.dictionary")
'Номер последней строки на листе запчасти по столбцу 1 lr = shZ.Cells(Rows.Count, 1).End(xlUp).Row 'Запоминаем в массив первые 3 столбца на листе запчасти arrZ = shZ.Cells(2, 1).Resize(lr - 1, 3).Value 'идем по строкам этого массива For i = 1 To UBound(arrZ) 'Если в словаре нет такого авто If Not dic.exists(Trim(arrZ(i, 1))) Then 'arrZ(i, 1) - авто в 1-м столбце ReDim temp(0) 'запоминаем артикул во временный массив temp(0) = Trim(arrZ(i, 3)) 'arrZ(i, 3) - артикул в 3-м столбце Else 'Если есть, считываем во временный массив все артикулы данного авто arrZ(i, 1) temp = dic(Trim(arrZ(i, 1))) 'Увеличиваем размерность массива на 1 ReDim Preserve temp(0 To UBound(temp) + 1) 'В последний элемент массива запоминаем текущий артикул arrZ(i, 3) temp(UBound(temp)) = Trim(arrZ(i, 3)) End If ' dic(Trim(arrZ(i, 1))) = temp Next i
'На данном этапе у нас сформировался словарь (набор пар ключ-значение), у которого авто в ключах, 'массив артикулов для данного авто в значениях
''Номер последней строки на листе авто по столбцу 1 lr = shA.Cells(Rows.Count, 1).End(xlUp).Row 'Очищаем старые значения на листе авто shA.[a1].CurrentRegion.Offset(1, 1).ClearContents With shA 'Идем по строкам For i = 2 To lr 'запомнили авто из 1-го столбца в переменную dItem dItem = Trim(.Cells(i, 1)) 'Если такое авто есть в словаре If dic.exists(dItem) Then 'записываем на лист артикулы (начиная со 2-го столбца и вправо) .Cells(i, 2).Resize(, UBound(dic(dItem)) + 1) = dic(dItem) End If Next i End With Application.ScreenUpdating = True End Sub
[/vba]
CoshVSR, попробуйте такой вариант: [vba]
Код
Sub test() Application.ScreenUpdating = False Dim shA As Worksheet, shZ As Worksheet, dic As Object Dim arrZ, temp$() Dim i&, lr&, dItem$
Set shA = Sheets("Авто") Set shZ = Sheets("запчасти") 'Будем записывать все артикулы в словарь (авто - ключ, массив артикулов - значение) Set dic = CreateObject("scripting.dictionary")
'Номер последней строки на листе запчасти по столбцу 1 lr = shZ.Cells(Rows.Count, 1).End(xlUp).Row 'Запоминаем в массив первые 3 столбца на листе запчасти arrZ = shZ.Cells(2, 1).Resize(lr - 1, 3).Value 'идем по строкам этого массива For i = 1 To UBound(arrZ) 'Если в словаре нет такого авто If Not dic.exists(Trim(arrZ(i, 1))) Then 'arrZ(i, 1) - авто в 1-м столбце ReDim temp(0) 'запоминаем артикул во временный массив temp(0) = Trim(arrZ(i, 3)) 'arrZ(i, 3) - артикул в 3-м столбце Else 'Если есть, считываем во временный массив все артикулы данного авто arrZ(i, 1) temp = dic(Trim(arrZ(i, 1))) 'Увеличиваем размерность массива на 1 ReDim Preserve temp(0 To UBound(temp) + 1) 'В последний элемент массива запоминаем текущий артикул arrZ(i, 3) temp(UBound(temp)) = Trim(arrZ(i, 3)) End If ' dic(Trim(arrZ(i, 1))) = temp Next i
'На данном этапе у нас сформировался словарь (набор пар ключ-значение), у которого авто в ключах, 'массив артикулов для данного авто в значениях
''Номер последней строки на листе авто по столбцу 1 lr = shA.Cells(Rows.Count, 1).End(xlUp).Row 'Очищаем старые значения на листе авто shA.[a1].CurrentRegion.Offset(1, 1).ClearContents With shA 'Идем по строкам For i = 2 To lr 'запомнили авто из 1-го столбца в переменную dItem dItem = Trim(.Cells(i, 1)) 'Если такое авто есть в словаре If dic.exists(dItem) Then 'записываем на лист артикулы (начиная со 2-го столбца и вправо) .Cells(i, 2).Resize(, UBound(dic(dItem)) + 1) = dic(dItem) End If Next i End With Application.ScreenUpdating = True End Sub
Спасибо, а можете также написать комментарии к коду ? 1. Номер столбца, в котором ищется название авто. 2. Номер столбца, с которого макрос начинает "разносить" значения артикулов 3. Номер столбца в запчастях, в котором макрос ищет соответствие названию авто из п.1
Спасибо, а можете также написать комментарии к коду ? 1. Номер столбца, в котором ищется название авто. 2. Номер столбца, с которого макрос начинает "разносить" значения артикулов 3. Номер столбца в запчастях, в котором макрос ищет соответствие названию авто из п.1CoshVSR
CoshVSR, добавила комменты выше. Новичку сложно будет разобраться со словарями и массивами. Лучше бы скинули файл с реальной структурой таблиц, тогда и код бы править не пришлось...
CoshVSR, добавила комменты выше. Новичку сложно будет разобраться со словарями и массивами. Лучше бы скинули файл с реальной структурой таблиц, тогда и код бы править не пришлось...Manyasha