Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

VBA - Dictionary Object to count occurrences of 5 different criterias.

Posted on 2008-06-19
14
Medium Priority
?
806 Views
Last Modified: 2013-11-25
Hi everyone, I have a question on how to use the VBA equivalent of excel's "countif" to determine the occurences of a set of criterias. I was assisted earlier on how to use the Dictionary Object to find the unqiue "counterparties"; now, I would like to be able to count the occurences of all unique counterparties that fall in the following criterias:

1) "31-60"
2) "61-90"
3) "91-180
4)"Over 180"

Thanks everyone.
0
Comment
Question by:Shino_skay
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 8
  • 6
14 Comments
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21827027
It may help to start with the code already completed, which I have attached for reference.

As the data is now in a dictionary object, we are going to have to write a routine to actually do the processing - there isn't a countif equivalent that can be used exactly, but of course, we can write what we need.  I'll have a play and post some code in a bit (if no-one has got here first!)
Sub test()
Dim i As Integer
Dim dicCounterParties
Dim srcWorksheet As Worksheet
Dim strCounterParty As String
Dim intFailedDays As String
 
Set dicCounterParties = CreateObject("Scripting.Dictionary")
Set srcWorksheet = ActiveSheet
i = 1
While srcWorksheet.Cells(i, 1).Value <> ""
        strCounterParty = srcWorksheet.Cells(i, 1).Value
        intFailedDays = CInt(srcWorksheet.Cells(i, 2).Value)
        If dicCounterParties.Exists(strCounterParty) Then
                intFailedDays = intFailedDays + CInt(dicCounterParties(strCounterParty))
                dicCounterParties(strCounterParty) = intFailedDays
        Else
                dicCounterParties.Add strCounterParty, intFailedDays
        End If
        i = i + 1
Wend
End Sub

Open in new window

0
 
LVL 24

Accepted Solution

by:
purplepomegranite earned 2000 total points
ID: 21827316
The attached demonstrates how to do this.

Simply paste all the code into an Excel module - as before, it assumes the required data is on the active worksheet.  The procedure to call is "Test" (you can see there are three now).

I've put a couple of comments in to show what is going on, though admittedly not many!  Ask if you have any questions!!
Option Explicit ' Can prevent silly mistakes with variables!!
 
' Declare module level variable
Dim dicCounterParties
 
Sub Test()
   Dim strResults As String
   Dim strMatches As String
   Dim intCount As Integer
   
   BuildDictionary
   strResults = "Summary" & vbCrLf & vbCrLf
   intCount = CountIf(31, 60, strMatches)
   strResults = strResults & "31-60: " & CStr(intCount) & " matches (" & strMatches & ")" & vbCrLf
   intCount = CountIf(61, 90, strMatches)
   strResults = strResults & "61-90: " & CStr(intCount) & " matches (" & strMatches & ")" & vbCrLf
   intCount = CountIf(91, 180, strMatches)
   strResults = strResults & "91-180: " & CStr(intCount) & " matches (" & strMatches & ")" & vbCrLf
   intCount = CountIf(181, 32767, strMatches) ' In this case the maximum is the maximum possible value for an integer
   strResults = strResults & "91-180: " & CStr(intCount) & " matches (" & strMatches & ")" & vbCrLf
   MsgBox strResults, vbInformation + vbOKOnly, "Results"
End Sub
 
Sub BuildDictionary()
   Dim i As Integer
   Dim srcWorksheet As Worksheet
   Dim strCounterParty As String
   Dim intFailedDays As String
    
   Set dicCounterParties = CreateObject("Scripting.Dictionary")
   Set srcWorksheet = ActiveSheet
   i = 1
   While srcWorksheet.Cells(i, 1).Value <> ""
      strCounterParty = srcWorksheet.Cells(i, 1).Value
      intFailedDays = CInt(srcWorksheet.Cells(i, 2).Value)
      If dicCounterParties.Exists(strCounterParty) Then
         intFailedDays = intFailedDays + CInt(dicCounterParties(strCounterParty))
         dicCounterParties(strCounterParty) = intFailedDays
      Else
         dicCounterParties.Add strCounterParty, intFailedDays
      End If
      i = i + 1
   Wend
End Sub
 
Function CountIf(intMin As Integer, intMax As Integer, Optional ByRef strMatches As String) As Integer
   ' Counts the number of matches given the range
   ' Returns the names of the counterparties in optional variable
   Dim k
   Dim i As Integer
   Dim intCount As Integer
   
   k = dicCounterParties.Keys
   intCount = 0
   strMatches = ""
   For i = 0 To dicCounterParties.Count - 1
      If dicCounterParties(k(i)) >= intMin And dicCounterParties(k(i)) <= intMax Then
         ' This entry matches the criteria
         intCount = intCount + 1 ' Add this occurrence to the total
         If strMatches <> "" Then strMatches = strMatches & ", "
         strMatches = strMatches & k(i) ' Also make a note of the name
      End If
   Next
   CountIf = intCount ' Return the count
End Function

Open in new window

0
 

Author Comment

by:Shino_skay
ID: 21833856
Wow, purplepomegranite, thanks for writing this out. It looks quite complex to the untrained eye. It's going to take a while for me to understand every line of code and how it works. I'll start cranking at it. Have a great weekend.
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21834405
While it probably does look complicated, I have broken it down into subroutines so that hopefully it will make sense when you work your way through it.  Obviously if you have any questions, feel free to ask!

You have a good weekend too... I've got a poker tournament tomorrow, so it'll definitely be a good weekend for me!
0
 

Author Comment

by:Shino_skay
ID: 21857163
wow purple, i'm sitll have a hard time figuring out every bit of code. You threw a lot at me in 1 shot. I'm sure it'll help me in the long run but currently, its difficult to digest (and doesn't work). Quick question, what's the difference if I used the Application.WorksheetFunction.CountIf? I was thinking I can use the "proven" dictionary object to return unique values and paste it in a column. Then use the Usedrange.columns.count to determine how many rows then loop the application.worksheetfunction.countif. Just thinking rationally, I suspect this code will be a slow and inefficient for large data. sigh.. I'll give myself some more time before I resort to this. keep you updated.

0
 

Author Comment

by:Shino_skay
ID: 21857287
I modified the  intFailedDays = intFailedDays + CInt(dicCounterParties(strCounterParty)) to CStr instead of CInt or CDbl since it produced an error. The issue now is in the Countif Function:

k = dicCounterParties.Keys is not defined and I would need to reference it somehow to the Builddictionary subroutine.


0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21857417
Ok, first of all... what kind of values are we adding up here?  What is the maximum total likely to be?  If you can give me an idea of range, I will modify the code.  I will also add a few comments which should help you to understand what is happening at each point.
0
 

Author Comment

by:Shino_skay
ID: 21857467
okay, i'm close to solving this purple, dont help me yet. Forget what I said above. I realized your solution was looking at actual days failing and bucketing them while I was using a column that had buckets that had "31-60", "61-90", etc, thats why there was an error with the Test(). So once I figure out how to reference the function, then it's all good. I think better out loud, my apologies if you're annoyed.
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21857576
hehe, don't worry, I'm not annoyed in the slightest.  Just let me know if you want me to change things, or are just thinking out loud ;-)
0
 

Author Comment

by:Shino_skay
ID: 21858418
ugh, I'm a moron. You're code works beautifully (and it always did). I was only receiving an error because of the column headers. Were you ever this frustrated with VBA when you first started? I gave myself a huge headache for no reason.
0
 

Author Comment

by:Shino_skay
ID: 21858619
hmm, I did some testing and noticed something odd about the code. If Column A had names and B had days:
Andy : 31
Bryan 61
Charlie 91
David 181

would return:

31-60: 1 matches (andy)
61-90: 1 matches (bryan)
91-180: 1 matches (charlie)
91-180: 1 matches (david)

However, if

Andy : 31
Bryan: 61
Andy: 91
Andy: 181

Summary

31-60: 0 matches ()
61-90: 0 matches()
91-180: 1 matches(andy)
91-180: 1 matches(bryan)

I just noticed the last row should be >180. I'll change that part. Purple, could you please explain how come unique values are only being counted once, with the last occurence being recorded? Thanks.
0
 

Author Comment

by:Shino_skay
ID: 21858630
I meant

Andy : 31
Bryan: 61
Andy: 91
Bryan: 181

in the the 2nd example.
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 21859917
Unique variables are only added once because their existence is checked in the dictionary first (If dicCounterParties.Exists(strCounterParty)).  If a value already exists, then the existing value is read from the dictionary, and added to the entry that has just been read.  This value is then stored in the dictionary... so each time the same person is found, the total is increased.

You are right though, there is a bug in the code.  Line 20 should be:
strResults = strResults & ">180: " & CStr(intCount) & " matches (" & strMatches & ")" & vbCrLf

I obviously forgot to change that when I was copying and pasting!

And yes, when I first starting programming I was frequently frustrated.  I think most get to that point as they learn!
0
 

Author Comment

by:Shino_skay
ID: 21860160
Thanks purprle. I'll just have to go with what I know and paste the unique names in column A, then run the application worksheet function to loop through each bracket and populate the adjacent 4 columns given its respective criteria. Maybe somewhere along the way I can think out loud a more efficient way of doing this. Thanks again! I'm going to re-enter the frustration world now.  Oh yea, I hope you did well in your poker tournament. I've been getting real unlucky in mine. Multiple eliminations when it was 3-4 way(tourney style) and I have my man dominated. Just can't win when I'm ahead :(
0

Featured Post

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses

688 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question