Прописать формулу по 2 критериям. Необходимо собрать данные из таблицы 1 в таблицу 2 по критериям. Таблица разбита по блокам. Каждый блок это наименование статьи. В нее нужно затянуть по коду – наименование контрагента и его сумму.
Прописать формулу по 2 критериям. Необходимо собрать данные из таблицы 1 в таблицу 2 по критериям. Таблица разбита по блокам. Каждый блок это наименование статьи. В нее нужно затянуть по коду – наименование контрагента и его сумму.lexon992025
lexon992025, Добрый день! Скажите, а в статьях бывают разные коды статьи, например: "Материалы: Оборудование для видеонаблюдения, для КХО" код статьи только 1213600 или может быть ещё какой-то? Если контрагент встречается дважды в одной статье нужно складывать суммы?
lexon992025, Добрый день! Скажите, а в статьях бывают разные коды статьи, например: "Материалы: Оборудование для видеонаблюдения, для КХО" код статьи только 1213600 или может быть ещё какой-то? Если контрагент встречается дважды в одной статье нужно складывать суммы?msi2102
Сообщение отредактировал msi2102 - Четверг, 29.01.2026, 12:26
Sub Макрос2() arr = Worksheets("Лист1").Range("B5:E" & Worksheets("Лист1").Cells(Rows.Count, "E").End(xlUp).Row) Set sd = CreateObject("Scripting.Dictionary") For n = 1 To UBound(arr) If Not sd.Exists(arr(n, 4)) Then Set sd(arr(n, 4)) = CreateObject("Scripting.Dictionary") If Not sd(arr(n, 4)).Exists(arr(n, 3)) Then Set sd(arr(n, 4))(arr(n, 3)) = CreateObject("Scripting.Dictionary"): k = k + 1 If Not sd(arr(n, 4))(arr(n, 3)).Exists(arr(n, 1)) Then sd(arr(n, 4))(arr(n, 3)).Add arr(n, 1), arr(n, 2): k = k + 1 Else sd(arr(n, 4))(arr(n, 3))(arr(n, 1)) = sd(arr(n, 4))(arr(n, 3))(arr(n, 1)) + CLng(arr(n, 2)) End If Next ReDim arr_rez(1 To k, 1 To 3) n = 1: k = 1 For Each y In sd arr_rez(n, 2) = y arr_rez(n, 1) = "блок " & k n = n + 1: k = k + 1 For Each y1 In sd(y) For Each y2 In sd(y)(y1) arr_rez(n, 1) = y1 arr_rez(n, 2) = y2 arr_rez(n, 3) = sd(y)(y1)(y2) n = n + 1 Next Next Next Worksheets("Лист1").Range("G5").Resize(UBound(arr_rez), 3) = arr_rez End Sub
[/vba]
Не дождался ответа, сделал как понял: [vba]
Код
Sub Макрос2() arr = Worksheets("Лист1").Range("B5:E" & Worksheets("Лист1").Cells(Rows.Count, "E").End(xlUp).Row) Set sd = CreateObject("Scripting.Dictionary") For n = 1 To UBound(arr) If Not sd.Exists(arr(n, 4)) Then Set sd(arr(n, 4)) = CreateObject("Scripting.Dictionary") If Not sd(arr(n, 4)).Exists(arr(n, 3)) Then Set sd(arr(n, 4))(arr(n, 3)) = CreateObject("Scripting.Dictionary"): k = k + 1 If Not sd(arr(n, 4))(arr(n, 3)).Exists(arr(n, 1)) Then sd(arr(n, 4))(arr(n, 3)).Add arr(n, 1), arr(n, 2): k = k + 1 Else sd(arr(n, 4))(arr(n, 3))(arr(n, 1)) = sd(arr(n, 4))(arr(n, 3))(arr(n, 1)) + CLng(arr(n, 2)) End If Next ReDim arr_rez(1 To k, 1 To 3) n = 1: k = 1 For Each y In sd arr_rez(n, 2) = y arr_rez(n, 1) = "блок " & k n = n + 1: k = k + 1 For Each y1 In sd(y) For Each y2 In sd(y)(y1) arr_rez(n, 1) = y1 arr_rez(n, 2) = y2 arr_rez(n, 3) = sd(y)(y1)(y2) n = n + 1 Next Next Next Worksheets("Лист1").Range("G5").Resize(UBound(arr_rez), 3) = arr_rez End Sub
Код статьи присваивается только одной статье, в рамках статьи могут осуществляется закупки уже по направлению статью, например в рамках статьи "Материалы: Оборудование для видеонаблюдения, для КХО" можно закупить систему видеонаблюдения, маршрутизатор и т.д. Суммы складывать не нужно, т.к. у одного контрагента по одной статье может быть заключено несколько договоров по разным закупкам.
Код статьи присваивается только одной статье, в рамках статьи могут осуществляется закупки уже по направлению статью, например в рамках статьи "Материалы: Оборудование для видеонаблюдения, для КХО" можно закупить систему видеонаблюдения, маршрутизатор и т.д. Суммы складывать не нужно, т.к. у одного контрагента по одной статье может быть заключено несколько договоров по разным закупкам.lexon992025
Sub Макрос1() arr = Worksheets("Лист1").Range("B5:E" & Worksheets("Лист1").Cells(Rows.Count, "E").End(xlUp).Row) Set sd = CreateObject("Scripting.Dictionary") For n = 1 To UBound(arr) If Not sd.Exists(arr(n, 4) & "|" & arr(n, 3)) Then Set sd(arr(n, 4) & "|" & arr(n, 3)) = CreateObject("Scripting.Dictionary"): k = k + 1 If Not sd(arr(n, 4) & "|" & arr(n, 3)).Exists(arr(n, 1)) Then Set sd(arr(n, 4) & "|" & arr(n, 3))(arr(n, 1)) = CreateObject("Scripting.Dictionary") sd(arr(n, 4) & "|" & arr(n, 3))(arr(n, 1)).Add n, arr(n, 2): k = k + 1 Next ReDim arr_rez(1 To k, 1 To 3) n = 1: k = 1 For Each y In sd arr_rez(n, 2) = Split(y, "|")(0) kod = Split(y, "|")(1) arr_rez(n, 1) = "блок " & k n = n + 1: k = k + 1 For Each y1 In sd(y) For Each y2 In sd(y)(y1) arr_rez(n, 1) = kod 'y1 arr_rez(n, 2) = y1 arr_rez(n, 3) = sd(y)(y1)(y2) n = n + 1 Next Next Next Worksheets("Лист1").Range("G5").Resize(UBound(arr_rez), 3) = arr_rez End Sub
[/vba]
Пробуйте [vba]
Код
Sub Макрос1() arr = Worksheets("Лист1").Range("B5:E" & Worksheets("Лист1").Cells(Rows.Count, "E").End(xlUp).Row) Set sd = CreateObject("Scripting.Dictionary") For n = 1 To UBound(arr) If Not sd.Exists(arr(n, 4) & "|" & arr(n, 3)) Then Set sd(arr(n, 4) & "|" & arr(n, 3)) = CreateObject("Scripting.Dictionary"): k = k + 1 If Not sd(arr(n, 4) & "|" & arr(n, 3)).Exists(arr(n, 1)) Then Set sd(arr(n, 4) & "|" & arr(n, 3))(arr(n, 1)) = CreateObject("Scripting.Dictionary") sd(arr(n, 4) & "|" & arr(n, 3))(arr(n, 1)).Add n, arr(n, 2): k = k + 1 Next ReDim arr_rez(1 To k, 1 To 3) n = 1: k = 1 For Each y In sd arr_rez(n, 2) = Split(y, "|")(0) kod = Split(y, "|")(1) arr_rez(n, 1) = "блок " & k n = n + 1: k = k + 1 For Each y1 In sd(y) For Each y2 In sd(y)(y1) arr_rez(n, 1) = kod 'y1 arr_rez(n, 2) = y1 arr_rez(n, 3) = sd(y)(y1)(y2) n = n + 1 Next Next Next Worksheets("Лист1").Range("G5").Resize(UBound(arr_rez), 3) = arr_rez End Sub