Dynamic Counts

[ellison]

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

 

[MARK858]

@MoshiM , thanks for jumping in ?

 

[ellison]

So sorry MoshiM & huge thanks for your perseverance, but there are still some gremlins in there which are throwing out the counts!

On the plus side, "problem 1" from above is sorted (the one where it was culling some of the data from the results.

On the down side, the counts still seem to be off....?

 

[MoshiM]

So sorry MoshiM & huge thanks for your perseverance, but there are still some gremlins in there which are throwing out the counts!

On the plus side, "problem 1" from above is sorted (the one where it was culling some of the data from the results.

On the down side, the counts still seem to be off....?

Can you give an example of how the counts are off? Does your original data set have headers?

 

[MoshiM]

I've properly documented what each line does and made adjustments so that as long as you don't have a valid status within your headers(if they're present) then they won't affect anything along with fixing a likely error in the final array generation. Other than that, the notes may help you point out any inconsistencies in the logic needed.

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, Valid_Status() As String, VS_Number As Long

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

Valid_Status = Split("TBC,YES,NO,", ",") 'Upper case versions of valid statuses

For T = 1 To UBound(WS_Data, 1)

    Key = WorksheetFunction.Trim(LCase(WS_Data(T, 1)))    'Old data will be used as a key in the dictionary
   
    Status = UCase(WS_Data(T, 3))
   
    If Not IsError(Application.Match(Status, Valid_Status, 0)) Then 'If the status exists within the array of valid statuses then execute code block
       
        Y = Application.Match(Status, Valid_Status, 0) 'Find base 0 location of status within array +1 [Possibility count held at 0]
       
        VS_Number = VS_Number + 1 'Will be the # of Valid Statuses in the end
       
        If Not Items_D.Exists(Key) Then 'Create array within dictionary keyed to old data and use 1 as a value depending on status
                                                                                    
            Item = Array(1, 0, 0, 0) 'Array order is Possibility count[0], TBC count[1], Yes count[2], No count[3]
           
            Item(Y) = 1
           
            Items_D.Add Key, Item
           
            Erase Item
           
        Else 'It already exists, so update the status count for the corresponding array element depending on the status
       
            Item = Items_D.Item(Key)
           
            Item(Y) = Item(Y) + 1       'Overwrite the array element
         
            Item(0) = Item(0) + 1       'Increase [Possibility count] kept in array element 0
         
            Items_D.Item(Key) = Item    'Overwrite Dictionary array
           
            Erase Item
           
        End If
   
    End If
   
Next T

ReDim Array_S(1 To VS_Number + 1, 1 To 6) '+1 to leave a row for headers since they were maybe skipped when creating the dictionary

For T = 1 To VS_Number + 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
       
        Status = WS_Data(T - 1, 3) '-1 since headers occupy row 1
       
        If Not IsError(Application.Match(Status, Valid_Status, 0)) Then
       
          Item = Items_D.Item(WorksheetFunction.Trim(LCase(WS_Data(T - 1, 1)))) 'Find based on using lower case version of old data 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 - 1, 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
     
    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]

Ensured that there wouldn't be gaps in the final output.

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, Valid_Status() As String, VS_Number As Long, _
B As Long

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

Valid_Status = Split("TBC,YES,NO,", ",") 'Upper case versions of valid statuses

For T = 1 To UBound(WS_Data, 1)

    Key = WorksheetFunction.Trim(LCase(WS_Data(T, 1)))    'Old data will be used as a key in the dictionary

    Status = UCase(WS_Data(T, 3))

    If Not IsError(Application.Match(Status, Valid_Status, 0)) Then 'If the status exists within the array of valid statuses then execute code block
    
        Y = Application.Match(Status, Valid_Status, 0) 'Find base 0 location of status within array +1 [Possibility count held at 0]
    
        VS_Number = VS_Number + 1 'Will be the # of Valid Statuses in the end
    
        If Not Items_D.Exists(Key) Then 'Create array within dictionary keyed to old data and use 1 as a value depending on status
                                                                                
            Item = Array(1, 0, 0, 0) 'Array order is Possibility count[0], TBC count[1], Yes count[2], No count[3]
        
            Item(Y) = 1
        
            Items_D.Add Key, Item
        
            Erase Item
        
        Else 'It already exists, so update the status count for the corresponding array element depending on the status
    
            Item = Items_D.Item(Key)
        
            Item(Y) = Item(Y) + 1       'Overwrite the array element
      
            Item(0) = Item(0) + 1       'Increase [Possibility count] kept in array element 0
      
            Items_D.Item(Key) = Item    'Overwrite Dictionary array
        
            Erase Item
        
        End If

    End If

Next T

ReDim Array_S(1 To VS_Number + 1, 1 To 6) '+1 to leave a row for headers since they were maybe skipped when creating the dictionary

'Variable B conditionally used in case a non-valid status is found and so that data output is 1 block rather than several chunks

'on error resume next'Change this if you can figure out where an error might pop up

For T = 1 To UBound(WS_Data, 1) + 1 'loop all rows of data

    If T = 1 Then

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

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

End Sub

 

[ellison]

Sorry for radio silence Moshi, I've been trying to furiously to figure out at this end what is going wrong with the counts...

And I can't figure it out!

Would it help if I illustrated what I'm hoping to get on the counts?

For the count of "total # of possibilities"
1. copy "old data" & "new data" to separate sheet
2. remove duplicates
3. insert pivot table to do count only on the # of "old data"
4. run a vlookup from the original "old data" to that count

Similarly for the count of TBC's:

1. filter for status = TBC
2. copy "old data" & "new data" to separate sheet
3. remove duplicates
4. insert pivot table to do count only on the # of "old data"
5. run a vlookup from the original "old data" to that count

Same for "yes" and "no"


Wish I could help more, but I'm pretty perplexed!

 

[MoshiM]

3. remove duplicates

Can you provide an example of what a duplicate would look like and another where counts have gone wrong? You didn't mention the removal of duplicates previously.

There shouldn't be any errors in the counts. Are your expected counts incorrect? With the data you have provided at least, the counts are correct.

Also minor adjustments from previous versions:

Sub Counting_Stuff()

Dim Items_D As Object, Worksheet_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, Valid_Status() As String, VS_Number As Long, _
B As Long

Set Items_D = CreateObject("Scripting.Dictionary")

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

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

Valid_Status = Split("TBC,YES,NO,", ",") 'Upper case versions of valid statuses

For T = 1 To UBound(Worksheet_Data, 1)   'Loop all rows and create dictionary array if Status is valid

    Key = WorksheetFunction.Trim(LCase(Worksheet_Data(T, 1)))    'Old data will be used as a key

    Status = UCase(Worksheet_Data(T, 3))
  
    On Error Resume Next
  
    Y = Application.Match(Status, Valid_Status, 0) 'Find base 0 location of status within array + 1 [Possibility count held at 0]
  
    If Err.Number = 0 Then 'Status exists within the array of valid statuses so execute the below statements
      
        On Error GoTo 0
      
        VS_Number = VS_Number + 1 'Will be the # of Valid Statuses in the end
  
        If Not Items_D.Exists(Key) Then 'Create array within dictionary keyed to old data and use 1 as a value depending on status
                                                                              
            Item = Array(1, 0, 0, 0) 'Array order is Possibility count[0], TBC count[1], Yes count[2], No count[3]
      
            Item(Y) = 1
      
            Items_D.Add Key, Item
      
            Erase Item
      
        Else 'It already exists, so update the status count for the corresponding array element depending
  
            Item = Items_D.Item(Key)
      
            Item(Y) = Item(Y) + 1       'Overwrite the array element.Y determined above by finding where the status is within the Valid_Status array
    
            Item(0) = Item(0) + 1       'Increase [Possibility count] kept in array element 0
    
            Items_D.Item(Key) = Item    'Overwrite Dictionary array
      
            Erase Item
          
        End If
  
    Else'Invalid Status was found
        Err.Clear
    End If

Next T

On Error GoTo 0

ReDim Array_S(1 To VS_Number + 1, 1 To 6) '+1 to leave a row for headers since they were possibly skipped when creating the dictionary

For T = 1 To 6                            'Fill in Column Headers
    Array_S(1, T) = Array("Old Data", "New Data", "Total # Possibilities", "# TBC", "# Yes", "# No")(T - 1)
Next T

B = 1: 'B is conditionally used in case a non-valid status is found and so that data output is 1 block rather than several chunks

For T = 1 To UBound(Worksheet_Data, 1) 'Loop all rows
  
    Status = Worksheet_Data(T, 3)      'Assigned from 3rd column of the array [Hopefully your data starts in column A]

    If Not IsError(Application.Match(Status, Valid_Status, 0)) Then 'If status is valid then execute code
  
        Key = WorksheetFunction.Trim(LCase(Worksheet_Data(T, 1)))
      
        Item = Items_D.Item(Key)  'Find array within Dictionary based on key-[Old data]

        B = B + 1

        For Y = 1 To 6
  
            If Y <= 2 Then                     'Fill in Old and New data columns
                Array_S(B, Y) = Worksheet_Data(T, Y)
            Else                               'Retrieve data from dictionary
                Array_S(B, Y) = Item(Y - 3)    'Item array is base 0 so subtract 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

 

[MoshiM]

More optimizations and accounted for possible extra spaces at the end of Status strings.

Sub Counting_Stuff()

Dim Items_D As Object, Worksheet_Data() As Variant, T As Long, Keys() As Variant, Count_R() As Variant, Array_S() As Variant, _
Top_Left_Corner_Of_Destination_Range As Range, Y As Long, Status As String, Valid_Status() As String, VS_Number As Long, _
B As Long

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

If UBound(Worksheet_Data, 2) < 3 Then
    MsgBox "Not enough columns."
    Exit Sub
End If

With WorksheetFunction
    Keys = .Transpose(.Index(Worksheet_Data, 0, 1))
End With

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

Set Items_D = CreateObject("Scripting.Dictionary")

Valid_Status = Split("TBC,YES,NO", ",")     'Upper case versions of valid statuses

For T = 1 To UBound(Worksheet_Data, 1)      'Loop all rows and create dictionary array if Status is valid

    With WorksheetFunction
    
        Keys(T) = .Trim(LCase(Keys(T)))    'Old data will be used as a key if the status is valid
        Status = .Trim(UCase(Worksheet_Data(T, 3)))
        
        On Error Resume Next
        Y = .Match(Status, Valid_Status, 0) 'Find base 0 location of status within array + 1 [Possibility count held at 0]
    
    End With
    
    If Err.Number = 0 Then 'Status exists within the array of valid statuses so execute the below statements
      
        On Error GoTo 0
      
        VS_Number = VS_Number + 1 'Will be the # of Valid Statuses in the end
        
        With Items_D
        
            If Not .exists(Keys(T)) Then    'Create an array within dictionary keyed to old data
                                                                                    
                Count_R = Array(1, 0, 0, 0) 'Array order is Possibility count[0], TBC count[1], Yes count[2], No count[3]
            
                Count_R(Y) = 1              'Overwrite array element based on location of status within array Valid Status
            
                .Add Keys(T), Count_R
            
                Erase Count_R
            
            Else 'It already exists, so update the status count for the corresponding array element
    
                Count_R = .Item(Keys(T))
        
                Count_R(Y) = Count_R(Y) + 1       'Overwrite the array element.Y determined above by finding where the status is within the Valid_Status array
      
                Count_R(0) = Count_R(0) + 1       'Increase [Possibility count] kept in array element 0
      
                .Item(Keys(T)) = Count_R          'Overwrite Dictionary array
        
                Erase Count_R
            
            End If
          
        End With
 
    Else 'Invalid Status was found
        Err.Clear
    End If

Next T

On Error GoTo 0

ReDim Array_S(1 To VS_Number + 1, 1 To 6) '+1 to leave a row for headers since they were possibly skipped when creating the dictionary

For T = 1 To 6 'Column Headers in first row of array
    Array_S(1, T) = Array("Old Data", "New Data", "Total # Possibilities", "# TBC", "# Yes", "# No")(T - 1)
Next T

B = 1: 'B is conditionally used in case a non-valid status is found and so that data output is 1 block rather than several chunks

With Items_D

    For T = 1 To UBound(Worksheet_Data, 1)
        
        If .exists(Keys(T)) Then                                'Would only exist if in the above loop it was added based on its Status
            
            Count_R = .Item(Keys(T))                            'Find array within Dictionary based on key-[Old data]
            
            B = B + 1
    
            For Y = 1 To 6
      
                If Y <= 2 Then                                  'Fill in Old and New data columns
                    Array_S(B, Y) = Worksheet_Data(T, Y)
                Else                                            'Retrieve data from dictionary
                    Array_S(B, Y) = Count_R(Y - 3)              'Count_R array is base 0 so subtract 3 to compensate
                End If
          
            Next Y
        
        End If
    
    Next T

End With

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

End Sub

 

[ellison]

Moshi, you are such a gent for persevering - but there is still something that is throwing the counts out...

I'm wondering if there may be something in my actual data that is doing it? Or maybe something that I haven't explained very well.

Hope this may help.......

These are examples of the actual SKU's that we use in the old and new data

Checks I have done on the data:
made sure that everything in the Status is upper case
made sure there are no errors or comments etc
made sure there are no leading or trailing spaces
made sure there are no gaps
tried editing & removing anything that could be considered to act as a field separator etc

The Row # is only in there to help explain the counts I'm getting (which seem to be wrong)
Same for the Comment column - hopefully that may help shed some light?

By the way, if my column headers are a bit ambiguous, or I haven't explained this before very well, please can I apologise!

All the best

Row Number	Old Data	New Data	Status	Total # Possibilites	# TBC	# Yes	# No	Comment
1	TEXT:999999;TR	ABCDE00001234	TBC	4 - should be 1 as there is only one possible outcome for TEXT:999999;TR. But the count seems to be counting the # of rows, rather than the number of *different* rows - see comment field	4 - should be 1 as there is only one possible outcome which is TBC for this "old data" = TEXT:999999;TR and ABCDE00001234 - see comment field	0 - correct	0 - correct	Is the macro counting the number of rows which are "old Data" and "TBC" is? If so, it would be counting duplicated answers which would make the counts appear wrong. hope this makes sense!
2	TEXT:999999;TR	ABCDE00001234	TBC	4 - should be 1	4 - should be 1	0 - correct	0 - correct
3	TEXT:999999;TR	ABCDE00001234	TBC	4 - should be 1	4 - should be 1	0 - correct	0 - correct
4	TEXT:999999;TR	ABCDE00001234	TBC	4 - should be 1	4 - should be 1	0 - correct	0 - correct
5	TEXT:0003;TR	1234-56-789-1234	TBC	4 (this should be 1 as there is only 1 possible type of new data for this "old data") = 1234-56-789-1234 - see comment field	2 (this should be 1 as there is only one possibility which is TBC for this old data = TEXT:0003;TR and 1234-56-789-1234 - see comment field	1 - is correct as there is only 1 possibility which is YES for this old data = TEXT:0003;TR and 1234-56-789-1234	1 - is correct as there is only 1 possibility which is NO for this old data = TEXT:0003;TR and 1234-56-789-1234	i.e. even though the same info is on rows 5,6,7 and 8, it shouldn't be counted as "4". It should be counted as "1" And
6	TEXT:0003;TR	1234-56-789-1234	TBC	4 - should be 1	2 - should be 1	1 - correct	1 - correct
7	TEXT:0003;TR	1234-56-789-1234	YES	4 - should be 1	2 - should be 1	1 - correct	1 - correct
8	TEXT:0003;TR	1234-56-789-1234	NO	4 - should be 1	4 - should be 1	1 - correct	1 - correct

 

[MoshiM]

Try this. You shouldn't have to worry about Lower/Upper case or spaces anymore. Let me know if speed is becoming more of an issue.

Sub Counting_Stuff()

Dim Old_Data_D As Object, Worksheet_Data() As Variant, T As Long, OldData_Primary_Key() As Variant, Count_R() As Variant, _
Array_S() As Variant, Top_Left_Corner_Of_Destination_Range As Range, Y As Long, Status() As Variant, Update_Counts As Boolean, _
Valid_Status() As String, VS_Number As Long, B As Long, NewData_SubKey() As Variant, Sub_Dictionary As Object

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

If UBound(Worksheet_Data, 2) < 3 Then
    MsgBox "Not enough columns."
    Exit Sub
End If

Set Old_Data_D = CreateObject("Scripting.Dictionary")

With WorksheetFunction
    OldData_Primary_Key = .Transpose(.Index(Worksheet_Data, 0, 1))
    NewData_SubKey = .Transpose(.Index(Worksheet_Data, 0, 2))
    Status = .Transpose(.Index(Worksheet_Data, 0, 3))
End With

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

Valid_Status = Split("TBC,YES,NO", ",")     'Upper case versions of valid statuses

For T = 1 To UBound(Worksheet_Data, 1)      'Loop all rows and create dictionary array if Status is valid

    With WorksheetFunction
    
        Status(T) = Replace(UCase(Status(T)), " ", vbNullString)
        
        On Error Resume Next
        
        Y = .Match(Status(T), Valid_Status, 0) - 1 'Find base 0 location of status within array + 1 [Possibility count held at 0]
    
    End With
    
    If Err.Number <> 0 Then
    
        Err.Clear
        GoTo Skip_Dictionary_Creation_Loop
        
    Else
        On Error GoTo 0
        OldData_Primary_Key(T) = Replace(LCase(OldData_Primary_Key(T)), " ", vbNullString)  'Old data will be used as a key if the status is valid
        NewData_SubKey(T) = Replace(LCase(NewData_SubKey(T)), " ", vbNullString)
    End If
         
    VS_Number = VS_Number + 1 'Will be the # of Valid Statuses in the end
        
    With Old_Data_D
    
        If Not .exists(OldData_Primary_Key(T)) Then 'Create a Sub-Dictionary keyed to old data that will hold New Data
        
            .Add OldData_Primary_Key(T), CreateObject("Scripting.Dictionary") 'Dictionary within a dictionary
            
            .Item(OldData_Primary_Key(T)).Add "Status Counts", Array(0, 0, 0) 'Array order TBC count, Yes count, No count
            
        End If
        
        With .Item(OldData_Primary_Key(T))
            
            If Not .exists(NewData_SubKey(T)) Then 'If "New Data" doesn't exist within the created sub-dictionary
                
                Count_R = Array(0, 0, 0)     'Array order TBC count, Yes count, No count
                Count_R(Y) = 1               'Overwrite array element based on location of status within array Valid Status base 0
                
                .Add NewData_SubKey(T), Count_R
                
                Erase Count_R
                
                Update_Counts = True
                 
            Else
                'This section of code is what prevents duplicates
                Count_R = .Item(NewData_SubKey(T))
                
                If Not Count_R(Y) = 1 Then                      'determine if anything needs to change
                    
                    Count_R(Y) = 1
                    
                    .Item(NewData_SubKey(T)) = Count_R
                    
                    Update_Counts = True

                End If
                
                Erase Count_R
                
            End If
            
            If Update_Counts = True Then 'Update counts for all Sub Dictionaries linked to Old Data
            
                Count_R = .Item("Status Counts")
                Count_R(Y) = Count_R(Y) + 1
                .Item("Status Counts") = Count_R
                
                Update_Counts = False
                Erase Count_R
                
            End If
            
        End With
      
    End With

Skip_Dictionary_Creation_Loop:

Next T

On Error GoTo 0

ReDim Array_S(1 To VS_Number + 1, 1 To 6) '+1 to leave a row for headers since they were possibly skipped when creating the dictionary

For T = 1 To 6 'Column Headers in first row of array
    Array_S(1, T) = Array("Old Data", "New Data", "Total # Possibilities", "# TBC", "# Yes", "# No")(T - 1)
Next T

B = 1: 'B is conditionally used in case a non-valid status is found and so that data output is 1 block rather than several chunks

With Old_Data_D

    For T = 1 To UBound(Worksheet_Data, 1)
    
        On Error Resume Next
        Y = WorksheetFunction.Match(Status(T), Valid_Status, 0) - 1 'Just used to determine whether or not to execute code
        
        If Err.Number = 0 Then
            
            With .Item(OldData_Primary_Key(T))
                
                Count_R = .Item("Status Counts") 'Sub Key should always exist
                
                B = B + 1
        
                For Y = 1 To 6
          
                    If Y <= 2 Then                           'Fill in Old and New data columns
                    
                        Array_S(B, Y) = Worksheet_Data(T, Y)
                        
                    ElseIf Y = 3 Then
                    
                        Array_S(B, Y) = .Count - 1           '[Possibility count] Number of arrays within
                                                             'the Primary dictionary keyed to Old Data - 1 since there is a Status Count array
                    Else
                    
                        Array_S(B, Y) = Count_R(Y - 4)       'Count_R array is base 0 so subtract 4 to compensate
                    
                    End If
              
                Next Y
                
            End With
        Else
            Err.Clear
        End If
    
    Next T

End With

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

End Sub