Есть массив где в одном столбце названия в другом столбце коды. Необходимо строки с одинаковым название объединить в одну строку, а коды при этом транспонировать в столбцы. Пример в приложенном файле
Есть массив где в одном столбце названия в другом столбце коды. Необходимо строки с одинаковым название объединить в одну строку, а коды при этом транспонировать в столбцы. Пример в приложенном файлеFlanker70
let Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], Индекс = Table.AddIndexColumn(Источник, "Индекс", 0, 1, Int64.Type), Остаток = Table.TransformColumns(Индекс, {{"Индекс", each Number.Mod(_, 4), type number}}), Свод = Table.Pivot(Table.TransformColumnTypes(Остаток, {{"Индекс", type text}}, "ru-RU"), List.Distinct(Table.TransformColumnTypes(Остаток, {{"Индекс", type text}}, "ru-RU")[Индекс]), "Индекс", "КОД"), Имя = Table.RenameColumns(Свод,{{"0", "Код_1"}, {"1", "Код_2"}, {"2", "Код_3"}, {"3", "Код_4"}}) in Имя
[/vba]
или так: [vba]
Код
let Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], Группа = Table.Group( Источник, {"Наименование", "ИНН"}, {{ "Количество", (t) => [filter = Table.Transpose(Table.LastN(Table.SelectColumns(t, "КОД"), 4))][filter] }}), Результат = Table.ExpandTableColumn(Группа, "Количество", {"Column1", "Column2", "Column3", "Column4"}, {"Код_1", "Код_2", "Код_3", "Код_4"}) in Результат
[/vba]
Если у Вас офис 2019 и выше то такими формулами: Наименование
Код
=УНИК(A4:A15)
ИНН
Код
=ВПР(E9;$A$4:$C$15;2;0)
Код
Код
=ТРАНСП(ФИЛЬТР($C$4:$C$15;$A$4:$A$15=E9))
Можно Power Query, вот кнопочный вариант: [vba]
Код
let Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], Индекс = Table.AddIndexColumn(Источник, "Индекс", 0, 1, Int64.Type), Остаток = Table.TransformColumns(Индекс, {{"Индекс", each Number.Mod(_, 4), type number}}), Свод = Table.Pivot(Table.TransformColumnTypes(Остаток, {{"Индекс", type text}}, "ru-RU"), List.Distinct(Table.TransformColumnTypes(Остаток, {{"Индекс", type text}}, "ru-RU")[Индекс]), "Индекс", "КОД"), Имя = Table.RenameColumns(Свод,{{"0", "Код_1"}, {"1", "Код_2"}, {"2", "Код_3"}, {"3", "Код_4"}}) in Имя
[/vba]
или так: [vba]
Код
let Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], Группа = Table.Group( Источник, {"Наименование", "ИНН"}, {{ "Количество", (t) => [filter = Table.Transpose(Table.LastN(Table.SelectColumns(t, "КОД"), 4))][filter] }}), Результат = Table.ExpandTableColumn(Группа, "Количество", {"Column1", "Column2", "Column3", "Column4"}, {"Код_1", "Код_2", "Код_3", "Код_4"}) in Результат
[/vba]
Если у Вас офис 2019 и выше то такими формулами: Наименование
msi2102, Спасибо! Буду пробовать. Я правильно понял, что так как у меня MS Excel 2010 то это решение только с применением макросов? Беда в том, что у меня на работе стоит запрет на применение макросов. Попробую в домашних условиях исправить файл.
msi2102, Спасибо! Буду пробовать. Я правильно понял, что так как у меня MS Excel 2010 то это решение только с применением макросов? Беда в том, что у меня на работе стоит запрет на применение макросов. Попробую в домашних условиях исправить файл. Flanker70
Sub Макрос1() Dim arr, arr1, n As Long, m As Integer Set dic = CreateObject("Scripting.Dictionary") Set dic1 = CreateObject("Scripting.Dictionary") arr = Range("A4:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value m = 0 For n = 1 To UBound(arr) If Not dic.exists(arr(n, 1) & "|" & arr(n, 2)) Then Set dic(arr(n, 1) & "|" & arr(n, 2)) = CreateObject("Scripting.Dictionary") dic(arr(n, 1) & "|" & arr(n, 2))(dic(arr(n, 1) & "|" & arr(n, 2)).Count) = (arr(n, 3)) If m < dic(arr(n, 1) & "|" & arr(n, 2)).Count Then m = dic(arr(n, 1) & "|" & arr(n, 2)).Count Next dic1.Add "Наименование", "Наименование" dic1.Add "ИНН", "ИНН" For n = 1 To m dic1.Add "Код_" & n, "Код_" & n Next ReDim arr1(1 To dic.Count, 1 To 2 + m) n = 0 For Each y In dic n = n + 1 arr1(n, 1) = Split(y, "|")(0) arr1(n, 2) = Split(y, "|")(1) m = 2 For Each x In dic(y) m = m + 1 arr1(n, m) = dic(y).Item(x) Next Next Cells(13, 5).Resize(1, dic1.Count) = dic1.Items Cells(14, 5).Resize(UBound(arr1), UBound(arr1, 2)) = arr1 End Sub
[/vba]
Макросом, так макросом: [vba]
Код
Sub Макрос1() Dim arr, arr1, n As Long, m As Integer Set dic = CreateObject("Scripting.Dictionary") Set dic1 = CreateObject("Scripting.Dictionary") arr = Range("A4:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value m = 0 For n = 1 To UBound(arr) If Not dic.exists(arr(n, 1) & "|" & arr(n, 2)) Then Set dic(arr(n, 1) & "|" & arr(n, 2)) = CreateObject("Scripting.Dictionary") dic(arr(n, 1) & "|" & arr(n, 2))(dic(arr(n, 1) & "|" & arr(n, 2)).Count) = (arr(n, 3)) If m < dic(arr(n, 1) & "|" & arr(n, 2)).Count Then m = dic(arr(n, 1) & "|" & arr(n, 2)).Count Next dic1.Add "Наименование", "Наименование" dic1.Add "ИНН", "ИНН" For n = 1 To m dic1.Add "Код_" & n, "Код_" & n Next ReDim arr1(1 To dic.Count, 1 To 2 + m) n = 0 For Each y In dic n = n + 1 arr1(n, 1) = Split(y, "|")(0) arr1(n, 2) = Split(y, "|")(1) m = 2 For Each x In dic(y) m = m + 1 arr1(n, m) = dic(y).Item(x) Next Next Cells(13, 5).Resize(1, dic1.Count) = dic1.Items Cells(14, 5).Resize(UBound(arr1), UBound(arr1, 2)) = arr1 End Sub
msi2102, Еще раз спасибо! До домашнего компа не добрался. Проверить работу макроса не могу. А на работе нашел Майкрософт Стандарт 2019 но там этих функций нет. Есть только ФИЛЬТР.XML.
msi2102, Еще раз спасибо! До домашнего компа не добрался. Проверить работу макроса не могу. А на работе нашел Майкрософт Стандарт 2019 но там этих функций нет. Есть только ФИЛЬТР.XML. Flanker70
на работе нашел Майкрософт Стандарт 2019 но там этих функций нет
И не может быть. UNIQUE, FILTER и др. - функции динамических массивов, которые поддерживаются только в 365-ом офисе (по подписке) и 2021. С другой стороны, если у вас 2010, то вы можете скачать и установить бесплатную надстройку Power Query.Очень полезная вещь. Варианты решения в PQ Сергей выложил тремя постами выше. Также во вложении мой вариант со старыми функциями.
на работе нашел Майкрософт Стандарт 2019 но там этих функций нет
И не может быть. UNIQUE, FILTER и др. - функции динамических массивов, которые поддерживаются только в 365-ом офисе (по подписке) и 2021. С другой стороны, если у вас 2010, то вы можете скачать и установить бесплатную надстройку Power Query.Очень полезная вещь. Варианты решения в PQ Сергей выложил тремя постами выше. Также во вложении мой вариант со старыми функциями.Egyptian