Хранение значений в массиве и их подсчет.

[manula]

Здравствуйте коллеги подскажи пожалуйста как сделать такой велосипед: я задаю массив n-размерностью, затем мне нужно допустим считать в этот массив значения определенных ячеек одного столбца запомнить их и суммировать между собой.
Вот пример:

PHP код:

Янв    168,86
Фев    143,32
Март   3214,11  
Янв    53465,86
Март   756,98
Фев    312,22
Фев    644,34 


И нужно подсчитать суммы для Янв, Фев и Март - отдельно коллеги на новом листе, подсобите!

[Hugo121]

Словарь нужен - ищите scripting.dictionary
Хотя вот, всего-то:

Sub tt()
    Dim a(), i&
    a = [a1].CurrentRegion.Value 'раз уж заказан массив :)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2)
        Next
    End With
    'и вот всё в словаре :)
End Sub

[manula]

Тема созданная мной для решения проблемы была не решена, поэтому решил написать еще раз сюда.
Вот как я думал это реализовать:

Dim jj As Long
Dim cc As Range, g6$
Dim Янв(10) As Double
Dim Фев(10) As Double
Dim Март(10) As Double
jj = 1
ii = 1
For Each cc In Sheets("Лист1").UsedRange.Columns(1).Cells
 Select Case UCase(Sheets("Лист1").Range("C" & jj))
  
  Case "Янв"
    If Sheets("Лист1").Range("B" & jj).Value > 0 Then 
     Янв(ii) =  Sheets("Лист1").Cells(jj, 2)
     Sum = Sum + Янв(ii)
    End If
  Case "Фев"
   If Sheets("Лист1").Range("B" & jj).Value > 0 Then
     Фев(ii) =  Sheets("Лист1").Cells(jj, 2)
     Sum1 = Sum1 + Фев(ii)
   End If
  Case "Март"
   If Sheets("Лист1").Range("B" & jj).Value > 0 Then
     Март(ii) =  Sheets("Лист1").Cells(jj, 2)
     Sum2 = Sum2 + Март(ii)
   End If 
   jj = jj + 1
   ii = ii + 1
 End Select
Next cc

Вот что то на подобие такого алгоритма, только он конечно выглядит не очень и сыроват, ну думаю суть проблемы понятна, должно получиться что то вроде этого:
Янв = 168,86 + 53465,86
Фев = 143,32 + 312,22 + 644, 34
Март = 3214,11 + 756,98
Это не весь массив, для примера я взял столько значений просто.

[Hugo121]

И чем же не решена? Не добавлен вывод данных из словаря? Это было домашнее задание
А Ваш код конечно выглядит солиднее... Но это гланды через анус

Ответ на домашнее задание - две строки:

Sheets(2).[a1].Resize(.Count, 1) = Application.Transpose(.keys)
Sheets(2).[b1].Resize(.Count, 1) = Application.Transpose(.items)

[IgorGO]

Sub tt()
  Dim a(), b(), i&
  a = [a1].CurrentRegion.Value 'раз уж заказан массив :)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 2)
    Next
    'и вот всё в словаре :)
    
    'а вот и на листе
    [d1].Resize(.Count, 1).Value = WorksheetFunction.Transpose(.keys)
    [e1].Resize(.Count, 1).Value = WorksheetFunction.Transpose(.items)
  End With
End Sub

[IgorGO]

А Ваш код конечно выглядит солиднее...

да, уж... это только 3 месяца перечислено

manula,
за усидчивость - получается 5, а за домашнее в целое - не очень.

[manula]

Да понятно, щас ознакомлюсь с этим методом поподробнее, а не могли бы вы уважаемые еще мне подсказать как можно данным алгоритмом воспользоваться в приложенной к этому сообщению книге на "Лист2".

[IgorGO]

Private Sub CommandButton1_Click()
  Dim c&, r&, s0$
  For c = 3 To 8
    With CreateObject("Scripting.Dictionary")
      For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Trim(Cells(r, 1)) = "" Then
          If Cells(r, 2) <> "Итог:" Then s0 = Cells(r, 2)
        Else
          .Item(s0 & " " & Cells(r, 2)) = .Item(s0 & " " & Cells(r, 2)) + Cells(r, c)
        End If
      Next
      If c = 3 Then Cells(1, c).Offset(0, 7).Resize(.Count, 1).Value = WorksheetFunction.Transpose(.keys)
      Cells(1, c).Offset(0, 8).Resize(.Count, 1).Value = WorksheetFunction.Transpose(.items)
    End With
  Next
End Sub

[IgorGO]

и если с С по Н у Вас будут числа, а не текст, то Вы еще и суммы получите.

[Czeslaw]

Ваш пример легко решается консолидацией или функцией СУММЕСЛИ