vba суммирование данных по критерию

[tavoz]

Есть таблица Excel2003, где 1- столбец год и несколько столбцов с данными, длинна и ширина таблицы меняется(выгружается из базы). Мне нужно чтобы данные в столбцах суммировались с выводом сумм по годам под последней строкой данных таблицы. У меня получилось только прописывая каждый столбец отдельно, беда в том что я не могу заранее знать сколько будет столбцов. Помогите оптимизировать код vba Файл с примером моего кода прикреплен

[IgorGO]

оставте на листе только данные (удалите лишние строки)
скопируйте этот

Sub Banzay()
  Dim r As Long, YArr() As Range, i As Long, c As Long, U
  r = Cells(Rows.Count, 1).End(xlUp).Row
  U = UniqueArr(Cells(1, 1).Resize(r, 1), False)
  Cells(r + 1, 1).Resize(UBound(U), 1).Value = U
  ReDim YArr(UBound(U))
  YArr = ArrayRange(Cells(1, 1).Resize(r, 1), False)
  For i = 1 To UBound(U)
    For c = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
      Cells(r + i, c) = WorksheetFunction.Sum(YArr(i).Offset(0, c - 1))
    Next
  Next
End Sub





Function ArrayRange(FindRg As Range, Optional HasHead As Boolean = True)
  Dim a1, a2, i As Long
  a1 = UniqueArr(FindRg, HasHead)
  ReDim a2(1 To UBound(a1)) As Range
  For i = 1 To UBound(a1)
    Set a2(i) = FindAllAtRange(CStr(a1(i, 1)), FindRg)
  Next
  ArrayRange = a2
End Function



Function FindAllAtRange(What As String, FindRg As Range, Optional WithHead As Long = 0) As Range
  Dim ru As Range, rg As Range, adr As String
  If WithHead > 0 Then Set ru = FindRg.Cells(WithHead)
  Set rg = FindRg.Cells(1)
  Set rg = FindRg.Find(What, rg, xlValues, xlWhole):  If ru Is Nothing Then Set ru = rg
  If rg Is Nothing Then Exit Function Else Set ru = Union(rg, ru):  adr = rg.Address
  Do
    Set rg = FindRg.Find(What, rg)
    If rg.Address = adr Then Exit Do Else Set ru = Union(ru, rg)
  Loop
  Set FindAllAtRange = ru
End Function



Function UniqueArr(rg As Range, Optional HasHead As Boolean = True) As Variant
  Dim a, SU, DA, r As Long, h As Long, Wsht As Worksheet, Csht As Worksheet
  SU = Application.ScreenUpdating: Application.ScreenUpdating = False
  Set Csht = ActiveSheet:   Set Wsht = Worksheets.Add
  With Wsht
    rg.Copy .[a1]: h = IIf(HasHead, 1, 0)
    .[a1].Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).RemoveDuplicates Columns:=1, Header:=IIf(HasHead, xlYes, xlNo)
    With .Sort
      .SortFields.Clear
      .SortFields.Add Key:=Wsht.Cells(1).Offset(h, 0).Resize(Wsht.Cells(Wsht.Rows.Count, 1).End(xlUp).Row - h, 1) _
      , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Wsht.[a1].Resize(Wsht.Cells(Wsht.Rows.Count, 1).End(xlUp).Row, 1): .Header = IIf(HasHead, xlYes, xlNo)
      .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
    If WorksheetFunction.CountA(.Columns(1)) - h = 1 Then
      ReDim a(1, 1): a(1, 1) = .Cells(1, 1).Offset(h, 0): UniqueArr = a
    Else
      UniqueArr = .Cells(1, 1).Offset(h, 0).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - h).Value
    End If
  End With
  With Application
    Csht.Activate: DA = .DisplayAlerts: .DisplayAlerts = False: Wsht.Delete: .DisplayAlerts = DA: .ScreenUpdating = SU
  End With
End Function

в программный модуль Вашего файла

выполните Sub Banzay()

функции ArrayRange, FindAllAtRange, UniqueArr я публиковал тут ранее.
на мой взгляд, в смычке со стандартными функциями листа, ими можно решить 99% процентов задач связанных с вычислениями в табличных данных

[Hugo121]

Такой формулы не достаточно? Можно её макросом динамически ставить:

=SUMPRODUCT((A1:A22=2014)*B1:F22)

[SAS888]

Можно так:

Sub Main()
    Dim i As Long, j As Long, k As Long, x As Range, z As New Collection, a()
    Application.ScreenUpdating = False: Set x = [A:A].Find("Сумма ")
    If x Is Nothing Then k = Cells(Rows.Count, 1).End(xlUp).Row Else k = x.Row - 1
    Rows(k + 1 & ":" & Rows.Count).Clear: a = Range("A1:A" & k)
    On Error Resume Next
    For i = 1 To k
        z.Add a(i, 1), CStr(a(i, 1))
    Next
    On Error GoTo 0
    For i = 1 To z.Count
        Cells(k + i, 1) = "Сумма " & z(i)
        For j = 2 To ActiveSheet.UsedRange.Columns.Count
            Cells(k + i, j) = Application.SumIf(Range("A1:A" & k), z(i), Range(Cells(1, j), Cells(k, j)))
        Next
    Next
    With Rows(k + 1 & ":" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Font.Bold = True: .Font.ColorIndex = 3
    End With
End Sub

Пример во вложении.

[tavoz]

Всем большое спасибо за помощь

[svsh2016]

Доброго времени суток,поскольку ваша тема не закрыта высылаю вам макрос,с использованием словаря,без использования коллекции.Известно,что это способ в 8 раз увеличивает скорость,что важно при больших размерах исходных данных.
С уважением ко всем участникам обсуждения:

Sub insert()
    Dim arr1(), addr$, S$, arr2(), z(), d As Object, i&, j1&, n As Byte
 With Sheets("Лист1")
    j1 = .Range("A1").End(xlToRight).Column
    S = .Range("A1").Offset(, j1 - 1).Address(1, 0)
    S = Left(S, InStrRev(S, "$"))
    i1 = .Range("A1").End(xlDown).Row
    arr1 = .Range("A1:" & S & i1).Value
    ReDim arr2(1 To UBound(arr1), 2 To j1)
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = 1
    For i = 1 To UBound(arr1)
        If d.Exists(arr1(i, 1)) Then
        For n = 2 To j1: arr2(d(arr1(i, 1)), n) = arr2(d(arr1(i, 1)), n) + arr1(i, n): Next
        Else
        d(arr1(i, 1)) = i
        For n = 2 To j1: arr2(i, n) = arr1(i, n): Next
        End If
    Next
        .Range("B" & i1 + 1).Resize(i, j1 - 1) = arr2: z = d.Keys
      For n = 1 To d.Count
       .Range("A" & UBound(arr1)).Offset(n, 0) = "Сумма" & Chr(32) & z(n - 1)
       .Range("A" & UBound(arr1)).Offset(n, 0).Font.ColorIndex = 3
       .Range("A" & UBound(arr1)).Offset(n, 0).Font.Bold = True
       addr = .Range("A1").Offset(, j1).Address(1, 0)
       addr = Left(addr, InStrRev(addr, "$"))
       Range("B" & UBound(arr1) & ":" & addr & UBound(arr1)).Offset(n, 0).Font.Bold = True
      Next
 End With
 End Sub

[Hugo121]

svsh2016 - вот ещё версия для Вашего файла. Попроще и должна быть побыстрее. Красить жирностью не стал.
Использовал данные и процедуру clean (кстати это слово уже используется в Экселе, луше назвать её иначе):

Sub tt()
    Dim a(), i&, ii&, x&, y&, t$

    clean

    With CreateObject("scripting.dictionary"): .comparemode = 1
        a = [a1].CurrentRegion.Value
        For i = 1 To UBound(a): t = a(i, 1)
            If Not .exists(t) Then
                ii = ii + 1: .Item(t) = ii: For x = 1 To UBound(a, 2): a(ii, x) = a(i, x): Next
            Else
                y = .Item(t): For x = 2 To UBound(a, 2): a(y, x) = a(y, x) + a(i, x): Next
            End If
        Next
    End With

    For i = 1 To ii: a(i, 1) = "Сумма " & a(i, 1): Next    'ненужное украшательство, но нужное для процедуры "clean"... :(

    Cells(UBound(a) + 1, 1).Resize(ii, UBound(a, 2)) = a
End Sub

P.S. Ваш Sub insert1() там внизу чуть гадит, потому что i после цикла увеличивается на 1.