let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица_1"]}[Content],
    #"Сгруппированные строки" = Table.Group(Источник, {"Предприятие", "Группа", "Наименование"}, {{"Количество", each Ф_Накопительно(_,"Сумма"), type table}}),
    #"Развернутый элемент 1" = Table.ExpandTableColumn(#"Сгруппированные строки", "Количество", {"Дата", "Сумма", "Количество накопительно"}, {"Дата", "Сумма", "Кол-во накопительно"}),
    #"Развернутый элемент 2" = Table.ExpandListColumn(#"Развернутый элемент 1", "Кол-во накопительно"),
    #"Строки с применным фильтром1" = Table.SelectRows(#"Развернутый элемент 2", each ([#"Кол-во накопительно"] <> null)),
    #"Удаленные столбцы" = Table.RemoveColumns(#"Строки с применным фильтром1",{"Сумма"})
in
    #"Удаленные столбцы"

SELECT MONTH(BD.DATE) as DAT, MIN.AGENT, MIN.STROKA, Sum (([count]*([cena]/1000))) AS Summ1
СВЯЗИ
FROM BD,  MIN  WHERE (MIN.PODGRUPA Is Null And MIN.NAIMEN Is Null And MIN.NOM_NAKL Is Null)
GROUP BY MONTH(BD.DATE), MIN.AGENT, MIN.STROKA
UNION all
SELECT MONTH(BD.DATE) as DAT, MIN.AGENT, MIN.STROKA, Sum (([count]*([cena]/1000))) AS Summ1
СВЯЗИ
FROM BD, MIN WHERE (MIN.PODGRUPA Is Null And MIN.POLUCHA Is Null And MIN.NOM_NAKL Is Null)
GROUP BY MONTH(BD.DATE), MIN.AGENT, MIN.STROKA

SELECT MONTH(BD.DATE) as DAT, MIN.AGENT, MIN.STROKA, Sum (([count]*([cena]/1000))) AS Summ1
FROM BD,  MIN  WHERE (MIN.PODGRUPA Is Null And MIN.NAIMEN Is Null And MIN.NOM_NAKL Is Null)
GROUP BY MONTH(BD.DATE), MIN.AGENT, MIN.STROKA
UNION all
SELECT MONTH(BD.DATE) as DAT, MIN.AGENT, MIN.STROKA, Sum (([count]*([cena]/1000))) AS Summ1
FROM BD, MIN WHERE (MIN.PODGRUPA Is Null And MIN.POLUCHA Is Null And MIN.NOM_NAKL Is Null)
GROUP BY MONTH(BD.DATE), MIN.AGENT, MIN.STROKA

Array = rs.GetRows

[/CODE]п в том что есть массив 17000 на 90 его надо преобразовать в таблицу 1000 на 30 Поставил цикл на перебор переменных, но что то не получается, а если выходило то очень долго Возможно тут надо использовать или коллекции или словари, пока я их еще не освоил((
[CODE]Sub Преобразовать()
 Dim x, v, avArr, li As Long, lii As Long, sum As Double
    On Error Resume Next
    v = Range([a16910], [aa17910&#93 ;) .Value 
     For c1 = 2 To 10      
        li = 1
     For r1 = 1 To 10
        f = v(1, c1)  
        d = v(r1, 1)
    x = Range([b1], [ce16900&#93 ;) .Value
    For r2 = 1 To 10
     For c2 = 1 To 10
      e = x(r2, 1)
      g = x(1, c2)
      t = x(r2, c2)
       If e = d Then
         If Mid(g, 2, 1) = f Then
           sum = sum + t
         End If
       End If
     Next
    Next
     lii = c1
       avArr(li, lii) = sum
       li = li + 1
       sum = 0
    Next
    Next
 [a16910].Resize(li, 27).Value = avArr
 End Sub