Задача немного абстрактная. Но она не даёт мне покоя, так как примерно что-то подобное мне иногда требуется по работе. Вобщем есть список деталей и комплектующих. Он всегда постоянен. Затем есть изделия которые из этих деталей собираются. Количество деталей и их вид в каждом изделие разный. Есть заказ изделий, количество и вид изделий в нём тоже меняется от заказа к заказу. В итоге надо получить список деталей и их количество в зависимости от того что указано в заказе. Каркас файла сделал. На формулах наверно и сам разберусь как сделать. Но формулы не подходят по причине того что в будущем возможно появление новых изделий и совсем другой состав деталей в них. То есть нужен какой-то макрос. Наверняка что-то подобное уже сто раз было. Не знаю как задать условие для поиска примеров. Задача не срочная, но для общего развития и в качестве изучения VBA не даёт мне покоя. Прошу помощи в написании кода или хотя бы ссылок на аналогичные примеры.
Задача немного абстрактная. Но она не даёт мне покоя, так как примерно что-то подобное мне иногда требуется по работе. Вобщем есть список деталей и комплектующих. Он всегда постоянен. Затем есть изделия которые из этих деталей собираются. Количество деталей и их вид в каждом изделие разный. Есть заказ изделий, количество и вид изделий в нём тоже меняется от заказа к заказу. В итоге надо получить список деталей и их количество в зависимости от того что указано в заказе. Каркас файла сделал. На формулах наверно и сам разберусь как сделать. Но формулы не подходят по причине того что в будущем возможно появление новых изделий и совсем другой состав деталей в них. То есть нужен какой-то макрос. Наверняка что-то подобное уже сто раз было. Не знаю как задать условие для поиска примеров. Задача не срочная, но для общего развития и в качестве изучения VBA не даёт мне покоя. Прошу помощи в написании кода или хотя бы ссылок на аналогичные примеры.fairylive
Попробуйте так, сортировку делать было лень UPD по просьбе ТС добавил комментарии к коду [vba]
Код
Sub tt() Dim ws As Worksheet 'Создае объект - словарь Dim Zakaz As Object: Set Zakaz = CreateObject("Scripting.Dictionary") Dim arr(), arr1(), I As Long, J As Long
'Вычисляем последнюю заполенную строку на листе и создаем 2-х мерный массив из диапазона с названием изделий и их количеством With Sheets("ЗАКАЗ") arr1 = .Range("B3:C" & .Cells(Rows.Count, 2).End(xlUp).Row).Value End With 'Перебераем все листы в рабочей книге For Each ws In Worksheets With ws For J = 1 To UBound(arr1) 'Перебираем все названия изделий, взятые с листа ЗАКАЗ, проверяем на равенство названию листа If .Name = arr1(J, 1) Then 'Создаем 2-х мерный массив из названий деталей и их количества в изделии arr = .Range("A2:B" & .Cells(Rows.Count, 2).End(xlUp).Row).Value 'Перебираем название деталей, если они уже есть, прибавляем количесвто деталей, умноженное на количество изделий For I = 1 To UBound(arr) If arr(I, 1) <> "" Then If Zakaz.exists(arr(I, 1)) Then Zakaz.Item(arr(I, 1)) = Zakaz.Item(arr(I, 1)) + (arr(I, 2) * arr1(J, 2)) Else 'Если их нет, создаем новый элемент в словаре, равный количеству деталей в изделии, _ умноженному на количество изделий Zakaz.Add Key:=arr(I, 1), Item:=arr(I, 2) * arr1(J, 2) End If End If Next End If Next End With Next 'Очищаем и заполняем соответствующй диапазоно на листе Изготовление With Sheets("Изготовление") .Range("A3:B" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents .Cells(3, 1).Resize(Zakaz.Count, 1) = WorksheetFunction.Transpose(Zakaz.keys) .Cells(3, 2).Resize(Zakaz.Count, 1) = WorksheetFunction.Transpose(Zakaz.items) End With 'На всякий случай очищае переменные Erase arr: Erase arr1: Set Zakaz = Nothing End Sub
[/vba]
Попробуйте так, сортировку делать было лень UPD по просьбе ТС добавил комментарии к коду [vba]
Код
Sub tt() Dim ws As Worksheet 'Создае объект - словарь Dim Zakaz As Object: Set Zakaz = CreateObject("Scripting.Dictionary") Dim arr(), arr1(), I As Long, J As Long
'Вычисляем последнюю заполенную строку на листе и создаем 2-х мерный массив из диапазона с названием изделий и их количеством With Sheets("ЗАКАЗ") arr1 = .Range("B3:C" & .Cells(Rows.Count, 2).End(xlUp).Row).Value End With 'Перебераем все листы в рабочей книге For Each ws In Worksheets With ws For J = 1 To UBound(arr1) 'Перебираем все названия изделий, взятые с листа ЗАКАЗ, проверяем на равенство названию листа If .Name = arr1(J, 1) Then 'Создаем 2-х мерный массив из названий деталей и их количества в изделии arr = .Range("A2:B" & .Cells(Rows.Count, 2).End(xlUp).Row).Value 'Перебираем название деталей, если они уже есть, прибавляем количесвто деталей, умноженное на количество изделий For I = 1 To UBound(arr) If arr(I, 1) <> "" Then If Zakaz.exists(arr(I, 1)) Then Zakaz.Item(arr(I, 1)) = Zakaz.Item(arr(I, 1)) + (arr(I, 2) * arr1(J, 2)) Else 'Если их нет, создаем новый элемент в словаре, равный количеству деталей в изделии, _ умноженному на количество изделий Zakaz.Add Key:=arr(I, 1), Item:=arr(I, 2) * arr1(J, 2) End If End If Next End If Next End With Next 'Очищаем и заполняем соответствующй диапазоно на листе Изготовление With Sheets("Изготовление") .Range("A3:B" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents .Cells(3, 1).Resize(Zakaz.Count, 1) = WorksheetFunction.Transpose(Zakaz.keys) .Cells(3, 2).Resize(Zakaz.Count, 1) = WorksheetFunction.Transpose(Zakaz.items) End With 'На всякий случай очищае переменные Erase arr: Erase arr1: Set Zakaz = Nothing End Sub