Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Получить список деталей имея список изделий - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Получить список деталей имея список изделий (Макросы/Sub)
Получить список деталей имея список изделий
fairylive Дата: Четверг, 03.03.2016, 17:56 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 122
Репутация: 4 ±
Замечаний: 0% ±

Excel 2016
Задача немного абстрактная. Но она не даёт мне покоя, так как примерно что-то подобное мне иногда требуется по работе. Вобщем есть список деталей и комплектующих. Он всегда постоянен. Затем есть изделия которые из этих деталей собираются. Количество деталей и их вид в каждом изделие разный. Есть заказ изделий, количество и вид изделий в нём тоже меняется от заказа к заказу. В итоге надо получить список деталей и их количество в зависимости от того что указано в заказе.
Каркас файла сделал. На формулах наверно и сам разберусь как сделать. Но формулы не подходят по причине того что в будущем возможно появление новых изделий и совсем другой состав деталей в них. То есть нужен какой-то макрос.
Наверняка что-то подобное уже сто раз было. Не знаю как задать условие для поиска примеров.
Задача не срочная, но для общего развития и в качестве изучения VBA не даёт мне покоя. Прошу помощи в написании кода или хотя бы ссылок на аналогичные примеры.
К сообщению приложен файл: 9266699.xlsm (31.9 Kb)
 
Ответить
СообщениеЗадача немного абстрактная. Но она не даёт мне покоя, так как примерно что-то подобное мне иногда требуется по работе. Вобщем есть список деталей и комплектующих. Он всегда постоянен. Затем есть изделия которые из этих деталей собираются. Количество деталей и их вид в каждом изделие разный. Есть заказ изделий, количество и вид изделий в нём тоже меняется от заказа к заказу. В итоге надо получить список деталей и их количество в зависимости от того что указано в заказе.
Каркас файла сделал. На формулах наверно и сам разберусь как сделать. Но формулы не подходят по причине того что в будущем возможно появление новых изделий и совсем другой состав деталей в них. То есть нужен какой-то макрос.
Наверняка что-то подобное уже сто раз было. Не знаю как задать условие для поиска примеров.
Задача не срочная, но для общего развития и в качестве изучения VBA не даёт мне покоя. Прошу помощи в написании кода или хотя бы ссылок на аналогичные примеры.

Автор - fairylive
Дата добавления - 03.03.2016 в 17:56
МВТ Дата: Четверг, 03.03.2016, 19:33 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 476
Репутация: 137 ±
Замечаний: 0% ±

Excel 2007
Попробуйте так, сортировку делать было лень
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]


Сообщение отредактировал МВТ - Четверг, 03.03.2016, 20:42
 
Ответить
СообщениеПопробуйте так, сортировку делать было лень
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]

Автор - МВТ
Дата добавления - 03.03.2016 в 19:33
fairylive Дата: Четверг, 03.03.2016, 20:23 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 122
Репутация: 4 ±
Замечаний: 0% ±

Excel 2016
Попробуйте так, сортировку делать было лень

Ругается что-то.
[vba]
Код
earas arr:
[/vba]
это должно быть [vba]
Код
Erase arr
[/vba]?
Я поправил но всё равно ругается.

PS Хотя считает вроде верно.

PPS Вы не могли бы немного комментариев добавить. Вообще что-то ничего понять не могу. :(
К сообщению приложен файл: 7871398.png (18.9 Kb)


Сообщение отредактировал fairylive - Четверг, 03.03.2016, 20:27
 
Ответить
Сообщение
Попробуйте так, сортировку делать было лень

Ругается что-то.
[vba]
Код
earas arr:
[/vba]
это должно быть [vba]
Код
Erase arr
[/vba]?
Я поправил но всё равно ругается.

PS Хотя считает вроде верно.

PPS Вы не могли бы немного комментариев добавить. Вообще что-то ничего понять не могу. :(

Автор - fairylive
Дата добавления - 03.03.2016 в 20:23
МВТ Дата: Четверг, 03.03.2016, 20:26 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 476
Репутация: 137 ±
Замечаний: 0% ±

Excel 2007
Да, постфактум дописал строчку. Должно быть так
[vba]
Код
Erase arr: Erase arr1: Set Zakaz = Nothing
[/vba]
 
Ответить
СообщениеДа, постфактум дописал строчку. Должно быть так
[vba]
Код
Erase arr: Erase arr1: Set Zakaz = Nothing
[/vba]

Автор - МВТ
Дата добавления - 03.03.2016 в 20:26
fairylive Дата: Четверг, 03.03.2016, 20:32 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 122
Репутация: 4 ±
Замечаний: 0% ±

Excel 2016
МВТ, ага теперь не ругается. Буду пытаться разобраться в коде. Спасибо!
 
Ответить
СообщениеМВТ, ага теперь не ругается. Буду пытаться разобраться в коде. Спасибо!

Автор - fairylive
Дата добавления - 03.03.2016 в 20:32
fairylive Дата: Четверг, 03.03.2016, 20:58 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 122
Репутация: 4 ±
Замечаний: 0% ±

Excel 2016
МВТ, С комментариями сразу всё стало ясно! даже удивительно))) Спасибо ещё раз.
 
Ответить
СообщениеМВТ, С комментариями сразу всё стало ясно! даже удивительно))) Спасибо ещё раз.

Автор - fairylive
Дата добавления - 03.03.2016 в 20:58
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Получить список деталей имея список изделий (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!