1

Image

On the left is the hypothetical database. On the right is the result I would like to obtain. I would like to print all of the items of type B, as well as the sum and the count. I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.

Private Sub CommandButton1_Click() Dim dicDistincts As Scripting.Dictionary, _ dicDuplicates As Scripting.Dictionary Set dicDistincts = New Scripting.Dictionary Set dicDuplicates = New Scripting.Dictionary Dim i As Integer For i = 2 To 10 If Cells(i, 1).Value = "B" Then If Not dicDistincts.Exists(Cells(i, 2).Value) Then dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value Else dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value End If End If Next i For i = 0 To dicDuplicates.Count - 1 Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i)) Next i End Sub

EDIT: I tried with countifs but it return 0 for banana, apple and strawberry

EDIT 2: I corrected the countifs. Now it works.

Improve this question
7
  • 1
    Is there a reason you need to use VBA instead of a simple COUNTIFS and SUMIFS? Commented Mar 29, 2021 at 19:14
  • Yes, there is unfortunately Commented Mar 29, 2021 at 19:17
  • Well, can you at least just use Application.WorksheetFunction.CountIfs? Or is this an assignment where you have to use a scripting dictionary? Commented Mar 29, 2021 at 19:18
  • 2
    A pivot table would work nicely here. Commented Mar 29, 2021 at 19:19
  • @dwirony I edited my message and I followed your hint. However, it gives me 0 for banana, apple and strawberry. Commented Mar 29, 2021 at 19:43

3 Answers 3

Reset to default
1

If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.

Private Sub CommandButton1_Click() Dim dic As Scripting.Dictionary Dim arrData() Dim i As Long Dim ky As Variant Set dic = New Dictionary For i = 2 To 10 If Cells(i, 1).Value = "B" Then ky = Cells(i, 2).Value If Not dic.Exists(ky) Then arrData = Array(1, Cells(i, 3).Value) Else arrData = dic(ky) arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value) End If dic(ky) = arrData End If Next i Range("A1:C1").Copy Range("E1:G1") For i = 0 To dic.Count - 1 Range("E" & i + 2) = dic.Keys(i) Range("F" & i + 2).Resize(, 2) = dic.Items(i) Next i End Sub
Improve this answer
Sign up to request clarification or add additional context in comments.

2 Comments

what's the purpose of ky in the last for loop?
There's actually no purpose to it, things it's a remnant from something I was testing - I'll remove it.
1

Unique Sum and Unique Count with Double Dictionary

Option Explicit Private Sub CommandButton1_Click() Dim rg As Range With Range("A1").CurrentRegion Set rg = .Resize(.Rows.Count - 1).Offset(1) End With Dim Data As Variant: Data = rg.Value Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary") Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary") Dim i As Long For i = 1 To UBound(Data, 1) If Data(i, 1) = "B" Then cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum End If Next i ReDim Data(1 To cDict.Count, 1 To 3) i = 0 Dim Key As Variant For Each Key In cDict.Keys i = i + 1 Data(i, 1) = Key Data(i, 2) = sDict(Key) Data(i, 3) = cDict(Key) Next Key With Range("E2").Resize(, 3) .Resize(i).Value = Data .Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents End With End Sub
Improve this answer

Comments

1

This should work it uses loops through all bs and addes them if to the other list

Sub countBs() Dim Bs As Range 'list of the line of all Bs Dim B As Range 'each indiviual b in the B list Dim Item As Range 'each indivual item Dim adder As Range 'resturns nothing if b not fond in times Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected For Each B In Bs If B = "B" Then Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1)) If adder Is Nothing Then If Range("g2") = "" Then Set Item = Range("g2") Else Set Item = Range("g1").End(xlDown).Offset(1, 0) End If Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value Item.Offset(0, 2) = 1 Else adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1 End If End If Next B End Sub
Improve this answer

Comments

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.