Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Cобрать данные из столбца в строку
 
#1
25.11.2021 22:53:46
Добрый день.
Подскажите как реализовать следующее:
Есть красивая таблица где каждый объект представлен одной строкой с и значениями разбитыми по годам.
И есть плоская таблица в 1-ом столбце повторяющиеся объекты , 2 столбец, например, года и 3 столбец - значения.
Как макросом реализовать заполнение 1 таблицы из второй?
Т.е. что-то вроде формирования сводной таблицы, но не на чистом листе.
 
 
 
#2
25.11.2021 23:04:41
может просто из плоской построить руками Сводную таблицу?
P.S. А так как обычно - макросом.
Изменено: New - 26.11.2021 00:34:18
 
 
 
#3
25.11.2021 23:05:12
Все бы ничего, но выполнению задачи мешает столбец "какие-то данные" :) Откуда они и что с ними делать?  
 
 
 
#4
25.11.2021 23:34:36
Столбец "Какие-то данные" показывает, что в Табл1 есть и другие столбцы, которые нужны и их убирать не нужно.

Столбец "Параметры" из Табл2 = "Параметр" из Табл2 ).
Например: Для объекта1 из Табл2 суммируются все параметры за 2021 год и данная сумма заносится в ячейку С3 Табл1 (2021 год).

Можно конечно из плоской Табл2 сделать сводную, а потом "впром" проставить значения в Табл2, но хочется попробовать макросом такое реализовать.
 
 
 
#5
26.11.2021 01:32:00
venrt, я вот тут подумал... а вам формула не подойдёт?
Вставьте эту формулу в ячейку С3 и протяните вправо и вниз до конца таблицы
=СУММЕСЛИМН(Табл2!$C:$C;Табл2!$A:$A;$A3;Табл2!$B:$B;C$2)
См. файл
Изменено: New - 26.11.2021 01:33:29
 
 
 
#6
26.11.2021 08:46:23
Да, думал про формулу, думаю пойдёт на без рыбье))
 
 
 
#7
26.11.2021 08:57:03
или вы всё же макрос хотите?
 
 
 
#8
26.11.2021 09:15:52
Макросом
Код
Sub ZarpGod()
Dim dic1, arr1, i&, Tp1
Set dic1 = CreateObject("Scripting.Dictionary")
arr1 = Worksheets(2).Cells(1).CurrentRegion.Value
    For i = 2 To UBound(arr1, 1)
        If Not dic1.Exists(arr1(i, 1)) Then
Set dic1(arr1(i, 1)) = CreateObject("Scripting.Dictionary")
dic1(arr1(i, 1))(arr1(i, 2)) = arr1(i, 3)
        Else
dic1(arr1(i, 1))(arr1(i, 2)) = dic1(arr1(i, 1))(arr1(i, 2)) + arr1(i, 3)
        End If
    Next i
i = 3: For Each Tp1 In dic1.Keys
Worksheets(1).Cells(i, 3).Resize(1, dic1(Tp1).Count) = dic1(Tp1).items: i = i + 1
    Next
End Sub
Изменено: Евгений Смирнов - 26.11.2021 09:52:07
 
 
 
#9
26.11.2021 10:23:26
Цитата
написал:
или вы всё же макрос хотите?
Макросом у меня была идея проходится двумя Find суммировать, и потом получившуюся сумму вставлять в нужную ячейку. Практически таже СуммаЕсли.

Цитата
написал:
Макросом
О спасибо  
 
 
 
#10
26.11.2021 10:29:20
venrt Методом Find можно. Я тоже сначала хотел им написать. Код конечно получиться длиннее. Я со словарями не так давно разбирался. Решил попробовать получиться написать где словарь в словаре.
 
 
 
#11
26.11.2021 11:31:29
Евгений Смирнов, код отличный, только плохо, что выгрузка результата на лист идёт построчно. Если строк в таблице будет много (скажем сотни тысяч), то выгрузка может затянуться... Переложить бы результаты в двумерный массив и одной строкой выгрузить в С3...
Изменено: New - 26.11.2021 11:33:27
 
 
 
#12
26.11.2021 11:54:50
Такое сработает если порядок следования Объектов в Табл1 и Табл2 одинаковый, а если нет, то я вижу только построчный:
Код
    lr = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
    For i = 3 To lr
        s1 = Worksheets(1).Cells(i, 1)
        Worksheets(1).Cells(i, 3).Resize(1, dic1(s1).Count) = dic1(s1).Items
    Next i
Изменено: venrt - 26.11.2021 12:16:07
 
 
 
#13
26.11.2021 12:20:22
venrt, попробуйте так

Код
Sub FillTable()
    Dim arrData As Variant, Dict As Object, arrOut As Variant, i As Long, iKey As Variant, iCol As Long
    Dim arrData2 As Variant, LastRow As Long, n As Long
    
    arrData = Worksheets("Табл2").Range("A1").CurrentRegion
    Set Dict = CreateObject("Scripting.Dictionary")
        
    For i = 2 To UBound(arrData)
        If Not Dict.Exists(arrData(i, 1)) Then
            Set Dict.Item(arrData(i, 1)) = CreateObject("Scripting.Dictionary")
            Dict.Item(arrData(i, 1)).Item(arrData(i, 2)) = arrData(i, 3)
        Else
            Dict.Item(arrData(i, 1)).Item(arrData(i, 2)) = Dict.Item(arrData(i, 1)).Item(arrData(i, 2)) + arrData(i, 3)
        End If
    Next i
        
    With Worksheets("Табл1")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrData2 = .Range("A3:A" & LastRow).Value
    End With
    
    i = 0
    ReDim arrOut(1 To Dict.Count, 1 To 5) 'не знаем вторую размерность массива, иначе надо подключить библиотеку Dictionary
    
    For n = 1 To UBound(arrData2, 1)
        i = i + 1
        iCol = 0
        For Each iKey In Dict.Item(arrData2(n, 1)).Keys
            iCol = iCol + 1
            arrOut(i, iCol) = Dict.Item(arrData2(n, 1)).Item(iKey)
        Next iKey
    Next n
    
    Worksheets("Табл1").Range("C3").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value2 = arrOut
    MsgBox "Сделано!", vbInformation, ""
End Sub
Изменено: New - 26.11.2021 12:29:47
 
 
 
#14
26.11.2021 12:24:50
New Согласитесь задача не стояла сделать самый шустрый код. Деньги за это не платят. Зачем голову ломать.
Хотя там всего несколько строк изменить да 1 добавить, и будет двухмерный выходной массив
Изменено: Евгений Смирнов - 26.11.2021 13:58:21
 
 
 
#15
26.11.2021 12:28:52
Соглашусь
 
 
 
#16
27.11.2021 06:36:28
Все таки NEW в сообщении №11 прав. 2 мерный массив надо формировать в макросе, и даже не только из за скорости. Если исходные данные не сортированы, то выгрузка кривая. Немного изменил код

Код
Sub ZarpGod3() 'Формирование массива перед выгрузкой на лист
Dim dic1, arr1, Tp1, Tp2, i&, j&, sTime!
Set dic1 = CreateObject("Scripting.Dictionary"): sTime = Timer
arr1 = Worksheets(2).Cells(1).CurrentRegion.Value
    For i = 2 To UBound(arr1, 1)
        If Not dic1.Exists(arr1(i, 1)) Then
Set dic1(arr1(i, 1)) = CreateObject("Scripting.Dictionary")
dic1(arr1(i, 1))(arr1(i, 2)) = arr1(i, 3)
        Else
dic1(arr1(i, 1))(arr1(i, 2)) = dic1(arr1(i, 1))(arr1(i, 2)) + arr1(i, 3)
        End If
    Next i
Tp1 = Range("A3:A7").Value: Tp2 = Range("C2:E2").Value
ReDim arr1(1 To UBound(Tp1), 1 To UBound(Tp2, 2))
For i = 1 To UBound(Tp1): For j = 1 To UBound(Tp2, 2)
arr1(i, j) = dic1(Tp1(i, 1))(Tp2(1, j))
Next: Next
Worksheets(1).Cells(3, 3).Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub

Только надо чтобы были правильно заполнены диапазоны "A3:A7"  "C2:E2" на листе1 иначе будет ошибка. По хорошему их конечно тоже желательно сформировать в макросе.
 
 
 
#17
27.11.2021 09:34:46
PQ
Код
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Наименование", type text}, {"Год", Int64.Type}, {"Параметр", Int64.Type}}),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Changed Type", {{"Год", type text}}, "lt-LT"), List.Distinct(Table.TransformColumnTypes(#"Changed Type", {{"Год", type text}}, "lt-LT")[Год]), "Год", "Параметр", List.Sum),
    #"Added Conditional Column" = Table.AddColumn(#"Pivoted Column", "Custom", each if [2021] = 0 then "" else null ),
    #"Reordered Columns" = Table.ReorderColumns(#"Added Conditional Column",{"Наименование", "Custom", "2021", "2022", "2023"})
in
    #"Reordered Columns"
 
 
 
Страницы: 1
Наверх