Подсчет суммы по значениям из коллекции

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Подсчет суммы по значениям из коллекции (Макросы/Sub)

ant6729

Дата: Суббота, 02.09.2017, 21:28 | Сообщение № 1

Группа: Проверенные

Ранг: Ветеран

Сообщений: 533

Репутация: 2 ±

Замечаний: 40% ±

Excel 2010

Добрый вечер, не могу распотрошить задачу

Вот мой код...

[vba]

Код

Sub A56U()

Dim Msg As String
Dim Response As Long

Dim MyCollection As Collection
Dim Rng As Range
Dim Cell As Range
Dim vNum As Variant
Dim i&

lr = Sheets("Proc2").Range("A" & Rows.Count).End(xlUp).Row

For i = 8 To lr
Set Rng = Sheets("Proc2").Range("A8:A" & lr)
Set MyCollection = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
MyCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell
Next i
On Error GoTo 0

For Each vNum In MyCollection
For x = 8 To lr
If vNum = Sheets("Proc2").Cells(x, 1) Then
counter = counter + Sheets("Proc2").Cells(x, 6)

MsgBox counter
End If
Next x

Next vNum

Exit Sub

End Sub

[/vba]

Хочу, чтобы вывелось последовательно по каждому vNum сумма по шестому столбцу

С помощью Target по даблклик можно последовательно получить информацию по каждому значению, но для этого нужно все прокликать

[vba]

Код

lr = Sheets("Proc2").Cells(Rows.Count, 1).End(xlUp).Row
SelRow = Target.Row
Produce = Sheets("Proc2").Cells(SelRow, 1)
For x = 8 To lr
If Sheets("Proc2").Cells(x, 1) = Produce Then
counter = counter + Sheets("Proc2").Cells(x, 6)
Counter2 = Counter2 + Sheets("Proc2").Cells(x, 7)
Counter3 = Counter3 + 1
End If
Next x
w = Math.Round(counter, 2)
V = Math.Round(Counter2, 2)
sd = Counter3
On Error Resume Next
сs = Application.WorksheetFunction.VLookup(Target, Sheets("N15").Range("H2:I1000"), 2, False)
MsgBox "[" & w & "]" & " " & "[" & V & "]" & " " & "[" & sd & "]" & vbCrLf & vbCrLf & сs

[/vba]

А я на первом этапе хочу, чтобы VBA сам вывел по уникальному номеру из коллекции суммы по каждому уникальному значению последовательно... в несколько месседжбоксов

Прошу помочь с первым этапом, как скрестить значения коллекции с counter'om

Может, решение лежит через другие подходы, хотел бы посмотреть и другие направления решения.

Добрый вечер, не могу распотрошить задачу

Вот мой код...

[vba]

Код

К сообщению приложен файл: -2-.xlsx (9.5 Kb)

Сообщение отредактировал ant6729 - Суббота, 02.09.2017, 23:01

Ответить

СообщениеДобрый вечер, не могу распотрошить задачу

Вот мой код...

[vba]

Код

Автор - ant6729
Дата добавления - 02.09.2017 в 21:28

iMrTidy

Дата: Воскресенье, 03.09.2017, 01:31 | Сообщение № 2

Группа: Пользователи

Ранг: Участник

Сообщений: 85

Репутация: 14 ±

Замечаний: 0% ±

NO

ant6729, не смотрел Ваш код, но могу предложить такой вариант.

К сообщению приложен файл: -2-.xlsm (22.4 Kb)

Вышенаписанное мной не является истиной, но лишь моя точка зрения, которая скорее всего ошибочна.

Ответить

RAN

Дата: Воскресенье, 03.09.2017, 06:15 | Сообщение № 3

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

[vba]

Код

Sub мяу()
    Dim ar, ai, ak, arCount()
    Dim count1&, count2&
    Dim i&
    ar = [a8:f15]
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ar)
            .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 6)
        Next
        ak = .keys
        ai = .items
        ReDim arCount(.Count - 1)
        For i = 0 To .Count - 1
            If ai(i) <= 100 Then count1 = count1 + 1 Else count2 = count2 + 1
            arCount(i) = ak(i) & " - " & ai(i)
            MsgBox arCount(i)
        Next
        MsgBox Join(arCount, vbLf)
        MsgBox "До 100 - " & count1 & vbLf & "Свыше 100 или равно - " & count2
    End With
End Sub

[/vba]

Быть или не быть, вот в чем загвоздка!

Ответить

ant6729

Дата: Воскресенье, 03.09.2017, 08:20 | Сообщение № 4

Группа: Проверенные

Ранг: Ветеран

Сообщений: 533

Репутация: 2 ±

Замечаний: 40% ±

Excel 2010

Как только я осознаю, что начинаю волочить... и вот уже сам немного пишу и могу прописать 3-4 задачи сам себе...и гордости полные карманы...
Так появляется код или коды...которые вводят меня в интеллектуальную депрессию и я понимаю, что мне опять мне садиться, выделять время и копать... копать.. .копать...

Спасибо, iMrTidy и RAN за примеры Ваших реализаций задач!!!

Ответить

ant6729

Дата: Воскресенье, 03.09.2017, 21:52 | Сообщение № 5

Группа: Проверенные

Ранг: Ветеран

Сообщений: 533

Репутация: 2 ±

Замечаний: 40% ±

Excel 2010

Подскажите, а как это [vba]

Код

ar = [a8:f15]

[/vba] прописать до lr?

Что-то я и так и так пробую...

Ответить

iMrTidy

Дата: Воскресенье, 03.09.2017, 23:48 | Сообщение № 6

Группа: Пользователи

Ранг: Участник

Сообщений: 85

Репутация: 14 ±

Замечаний: 0% ±

NO

ant6729, массиву ar присваивается значение диапазона [a8:a15]

Вышенаписанное мной не является истиной, но лишь моя точка зрения, которая скорее всего ошибочна.

Ответить

_Boroda_

Дата: Понедельник, 04.09.2017, 09:21 | Сообщение № 7

Группа: Админы

Ранг: Местный житель

Сообщений: 17006

Репутация: 6667 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Так хотели?
[vba]

Код

ar = range("a8:f" & lr)

[/vba]
[vba]

Код

ar = range("a8").resize(lr - 8 +1,6)

[/vba]
Еще кучу вариантов можно...

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995