Dynamic Counts

ellison · Mar 23, 2020

Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up!

What we confirm (by reviewing it manually) is whether the relationship between our "old data" and our "new data" is TBC, Yes or No.

***What we'd like to put in are dynamic counts of i) the total number of possibilities ii) # TBC, iii) # Yes iv) # No***

By the way, we have looked at various ways of concatenating info, then doing pivot tables & counts... But we do this so often every day on all sorts of differently updated files that we are hoping there may be a better solution? Maybe involving VBA? The files are generally 20K-50K rows and formula type options don't seem to work I'm afraid.

Our Data is arranged in 3 columns:

NB, the explanation column is only to help illustrate what's here, we wouldn't actually need that!

Thanks for any help

Old Data	New Data	Status	Total # Possibilities	# TBC	# Yes	#No	Explanation (only for illustration)
composite	plastic	TBC	1	1	0	0	there is only one possible relationship between the old and new data. And it is "TBC".
wood	oak	TBC	2	1	1	0	There are 2 possiblities for "wood" = oak & rustic. And one of those is "TBC" and one is "yes"
wood	rustic	Yes	2	1	1	0	ditto above
414878	plastic	No	1	0	0	1	Sometimes our old data is not a text string, it's an order code which is a number. It has only one possiblity and that is a "no"
raw materials	finished product	No	2	0	1	1	For "raw materials", there are 2 possible "new data's". and one is "yes" and one is "no".
raw materials	check quarantine	Yes	2	0	1	1	ditto above

ellison · Mar 24, 2020

Hi Mark, that looks very promising thanks!! I did it on a short file with 500 lines and it worked.

Message box reads: 0.09secs

I'll try it on some larger files tomorrow and report back

Fingers crossed you may have cracked it!!!

All the best

MARK858 · Mar 24, 2020

It doesn't speed up the process much, but it doesn't leave the formulas afterwards so stops that affecting the calculation.
There are methods we can use to speed it up if needed once you report back.

ellison · Mar 25, 2020

Hi Mark, that definitely works, it took 668 seconds (just over 10 mins for anybody not so good with their maths like me!) to do a 50K row spreadsheet.

Did you say there may be a couple of methods to help speed this up?!

MARK858 · Mar 25, 2020

ellison said:
Did you say there may be a couple of methods to help speed this up?!

Yes there are. If no-one else posts one then I will look at it when I get bored later

ellison · Mar 25, 2020

haha thanks Mark, appreciated!

MARK858 · Mar 25, 2020

Sorry but I don't think that I am going to get time to look at this tonight (be jumping in and out for 10 minute spells) and then will be limited on board time (if at all) for the next 4 days.

You might be better off starting a new thread, posting the code and asking if anyone can speed it up.
Sorry but out of my control.

MoshiM · Mar 25, 2020

This should work if you are on Windows. It will output a list with their corresponding values (same order as your original example) starting at the location designated by the variable Top_Left_Corner_Of_Destination_Range, so change it if needed.

Also, read the comments.

VBA Code:

Sub Counting_Stuff()

Dim Items_D As Object, WS_Data() As Variant, T As Long, Key As String, Item As Variant, Array_S() As Variant, _
Top_Left_Corner_Of_Destination_Range As Range

Set Items_D = CreateObject("Scripting.Dictionary")

Set Top_Left_Corner_Of_Destination_Range = ActiveSheet.Range("H2") '<<< Edit this if needed

WS_Data = ActiveSheet.UsedRange.Value                              'Loads worksheet data to an array

For T= 2 To UBound(WS_Data, 1)'starts at 2 to skip headers

    Key = LCase(WS_Data(T, 1) & "->" & WS_Data(T, 2))              'Designate a key

    If Items_D.Exists(Key) Then                                    'check if key/item exists within dictionary

        Select Case UCase(WS_Data(T, 3)) 'if it already exists then update the corresponding array value
    
            Case "TBC": Items_D.Item(Key)(2) = Items_D.Item(Key)(2) + 1
            
            Case "YES": Items_D.Item(Key)(3) = Items_D.Item(Key)(3) + 1
            
            Case "NO":  Items_D.Item(Key)(4) = Items_D.Item(Key)(4) + 1
            
            
        End Select
    
    Else

        Select Case UCase(WS_Data(T, 3)) 'create dictionary item and use 1 as a value depending on status
    
            Case "TBC": Items_D.Add Key, Array(WS_Data(T, 1), WS_Data(T, 2), 1, 0, 0)
            
            Case "YES": Items_D.Add Key, Array(WS_Data(T, 1), WS_Data(T, 2), 0, 1, 0)
            
            Case "NO":  Items_D.Add Key, Array(WS_Data(T, 1), WS_Data(T, 2), 0, 0, 1)
              
        End Select
    
    
    End If

Next T

ReDim Array_S(1 To Items_D.Count, 1 To 6)

T = 0

For Each Item In Items_D.items 'This loop fills out the output array

    WS_Data = Item

    T = T + 1
    Array_S(T, 1) = Item(0)                     'Old Data
    Array_S(T, 2) = Item(1)                     'New Data
    Array_S(T, 3) = Item(2) + Item(3) + Item(4) 'Possibilities
    Array_S(T, 4) = Item(2)                     'TBC Count
    Array_S(T, 5) = Item(3)                     'Yes Count
    Array_S(T, 6) = Item(4)                     'No Count

Next Item

Top_Left_Corner_Of_Destination_Range.Resize(Items_D.Count, 6).Value2 = Array_S

End Sub

ellison · Mar 26, 2020

ooooooooooooh my god this worked really quickly - BUT the counts are off...... ooooh that had felt so close there!

Problems I can see I'm afraid are (using the sample data at the beginning of the post to illustrate):

The results get posted in a separate place - tick!

Prob 1:
However, the results should include the header and 6 rows of data
When it does this on the 6 rows of data, all 6 rows of data appear in the results.
However, when I loaded up 50K rows of data, then some of the results were culled. And only the unique combinations of cols A & B seemed to appear,

Prob 2:
The counts were off, even when I tried it on the 6 rows of data.
I'll bet there's a tiny thing in the code which has thrown it all out, grrr!
Here are the results that are correct vs the results (in brackets) that appeared,sorry

I also included an explanation column - which wouldn't normally appear in the results, but hopefully illustrates what we are after a little better!

All the best

Old Data	New Data	Status	Total # Possibilities	# TBC	# Yes	# No	Explanation
composite	plastic	TBC	1 (1)	1 (1)	0 (0)	0 (0)	composite has only 1 "new data" and it is TBC
wood	oak	TBC	2 (1)	1 (1)	1 (0)	0 (0)	wood has 2 "new data's" and one of those is Yes and one is TBC
wood	rustic	Yes	2 (1)	1 (0)	1 (1)	0 (0)	see above
414878	plastic	No	1 (1)	0 (0)	0 (0)	1 (1)	414878 has only 1 "new data" and it is No
raw materials	finished product	No	2 (1)	0 (0)	1 (0)	1 (1)	raw materials has 2 "new data's" and one of those is Yes and one is No
raw materials	check quarantine	Yes	2 (1)	0 (0)	1 (1)	1 (0)	see above

MoshiM · Mar 26, 2020

Try this one then:

VBA Code:

Sub Counting_Stuff()

Dim Items_D As Object, WS_Data() As Variant, T As Long, Key As String, Item() As Variant, Array_S() As Variant, _
Top_Left_Corner_Of_Destination_Range As Range, Y As Long, Status As String

Set Items_D = CreateObject("Scripting.Dictionary")

Set Top_Left_Corner_Of_Destination_Range = ActiveSheet.Range("I1") '<<< Edit this if needed

WS_Data = ActiveSheet.UsedRange.Value                              'Loads worksheet data to an array

For T = 2 To UBound(WS_Data, 1) 'starts at 2 to skip headers being added to the dictionary

    Key = WorksheetFunction.Trim(LCase(WS_Data(T, 1)))                                     'Old data used as a key
    
    Status = UCase(WS_Data(T, 3))
    
    If Items_D.Exists(Key) Then                                    'check if key/item exists within dictionary
    
        Item = Items_D.Item(Key)
        
        Select Case Status 'if it already exists then update the status count for the corresponding array element
            
            Case "TBC": Item(0) = Item(0) + 1
                
            Case "YES": Item(1) = Item(1) + 1
                 
            Case "NO": Item(2) = Item(2) + 1
                  
        End Select
        
        Items_D.Item(Key) = Item
        
    Else

        Select Case Status 'create dictionary item and use 1 as a value depending on status
    
            Case "TBC": Items_D.Add Key, Array(1, 0, 0)
            
            Case "YES": Items_D.Add Key, Array(0, 1, 0)
            
            Case "NO":  Items_D.Add Key, Array(0, 0, 1)
              
        End Select
    
    End If

Next T

ReDim Array_S(1 To UBound(WS_Data, 1), 1 To 6)

For T = 1 To UBound(WS_Data, 1)

    If T = 1 Then
       Array_S(T, 1) = "Old Data"
       Array_S(T, 2) = "New Data"
       Array_S(T, 3) = "Total # Possibilities"
       Array_S(T, 4) = "# TBC"
       Array_S(T, 5) = "# Yes"
       Array_S(T, 6) = "# No"
    Else
        
        Item = Items_D.Item(WorksheetFunction.Trim(LCase(WS_Data(T, 1)))) 'Find based on using lower case version of old data as as was used as the key when creating the dictionary
        
        For Y = 1 To 6
        
            If Y <= 2 Then
            
                Array_S(T, Y) = WS_Data(T, Y) 'Fill in old and new data columns
                
            ElseIf Y = 3 Then
            
                Array_S(T, Y) = Item(0) + Item(1) + Item(2) 'Possibillities count
                
            ElseIf Y > 3 Then                               'Retrieve data from dictionary
            
                Array_S(T, Y) = Item(Y - 4)                 'Array is base 0 so minus 4 to compensate
                
            End If
            
        Next Y
        
    End If
        
Next T

Top_Left_Corner_Of_Destination_Range.Resize(UBound(Array_S, 1), UBound(Array_S, 2)).Value2 = Array_S

End Sub

MoshiM · Mar 26, 2020

Pretty much the same as the above but may be slightly faster

VBA Code:

Sub Counting_Stuff()

Dim Items_D As Object, WS_Data() As Variant, T As Long, Key As String, Item() As Variant, Array_S() As Variant, _
Top_Left_Corner_Of_Destination_Range As Range, Y As Long, Status As String

Set Items_D = CreateObject("Scripting.Dictionary")

Set Top_Left_Corner_Of_Destination_Range = ActiveSheet.Range("I1") '<<< Edit this if needed

WS_Data = ActiveSheet.UsedRange.Value                              'Loads worksheet data to an array

For T = 2 To UBound(WS_Data, 1) 'starts at 2 to skip headers being added to the dictionary

    Key = WorksheetFunction.Trim(LCase(WS_Data(T, 1)))                                     'Old data used as a key
  
    Status = UCase(WS_Data(T, 3))
  
    If Items_D.Exists(Key) Then                                    'check if key/item exists within dictionary
  
        Item = Items_D.Item(Key)
      
        Select Case Status 'if it already exists then update the status count for the corresponding array element
          
            Case "TBC": Item(1) = Item(1) + 1

            Case "YES": Item(2) = Item(2) + 1

            Case "NO": Item(3) = Item(3) + 1
                      
        End Select
      
        Item(0) = Item(0) + 1 '[Possibility count]-Will increase regardless of if you have more than the listed statuses
      
        Items_D.Item(Key) = Item
      
    Else

        Select Case Status 'create dictionary item and use 1 as a value depending on status
  
            Case "TBC": Items_D.Add Key, Array(1, 1, 0, 0)
          
            Case "YES": Items_D.Add Key, Array(1, 0, 1, 0)
          
            Case "NO":  Items_D.Add Key, Array(1, 0, 0, 1)
            
        End Select
        'Array order is Possibility count,TBC count, Yes count ,No count
    End If

Next T

ReDim Array_S(1 To UBound(WS_Data, 1), 1 To 6)

For T = 1 To UBound(WS_Data, 1)

    If T = 1 Then
       Array_S(T, 1) = "Old Data"
       Array_S(T, 2) = "New Data"
       Array_S(T, 3) = "Total # Possibilities"
       Array_S(T, 4) = "# TBC"
       Array_S(T, 5) = "# Yes"
       Array_S(T, 6) = "# No"
    Else
      
        Item = Items_D.Item(WorksheetFunction.Trim(LCase(WS_Data(T, 1)))) 'Find based on using lower case version of old data as as was used as the key when creating the dictionary
      
        For Y = 1 To 6
      
            If Y <= 2 Then
          
                Array_S(T, Y) = WS_Data(T, Y) 'Fill in old and new data columns
              
            Else                               'Retrieve data from dictionary
          
                Array_S(T, Y) = Item(Y - 3)                 'Array is base 0 so minus 3 to compensate
              
            End If
          
        Next Y
      
    End If
      
Next T

Top_Left_Corner_Of_Destination_Range.Resize(UBound(Array_S, 1), UBound(Array_S, 2)).Value2 = Array_S

End Sub

Dynamic Counts

ellison

Active Member

ellison

Active Member

Excel Facts

MARK858

MrExcel MVP

ellison

Active Member

MARK858

MrExcel MVP

ellison

Active Member

MARK858

MrExcel MVP

MoshiM

Active Member

ellison

Active Member

MoshiM

Active Member

MoshiM

Active Member

Similar threads

Forum statistics

Share this page

Dynamic Counts

Active Member

Active Member

Excel Facts

MrExcel MVP

Active Member

MrExcel MVP

Active Member

MrExcel MVP

Active Member

Active Member

Active Member

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock