Efficient way to seperate values from 2 seperate 1D-arrays to multiple arrays

Question

I have two separate 1D-arrays, one that stores the ID-number and one that stores its matching values (can't change this). I need to do calculations on those values per ID. So what I would like to have is that every ID gets its own array with corresponding values. In reality my arrays can have millions of values and an unknown amount of different ID numbers (max 255).

Example arrays to seperate, they always have the same size and use the same valuecount:

valuecount = 8
Values {10,20,30,40,50,60,70,80, 0, 0, 0, 0, 0, 0, 0}
IDnrs  {1 , 1, 2, 1, 1, 3, 3, 1, 0, 0, 0, 0, 0, 0, 0}

Desired result:

Array ID 1: {10,20,40,50,80}
Array ID 2: {30}
Array ID 3: {60, 70}

Or in json format:

{1: {10,20,40,50,80}, 2: {30}, 3: {60, 70}}

Right now I solved it with the following code, but the last loop is very slow... It is because an array is replaced into a dictionary everytime, millions of times. What would be a faster way to separate the values into ID-matching arrays?

Dim arValues() As Variant, arIDnrs() As Variant, ValCount As Long
Public Sub SeperateArraysStackOverflow()

'incoming data to process
ValCount = 8
arValues = Array(0, 10, 30, 41, 71, 111, 112, 114, 164, 0, 0, 0, 0, 0, 0, 0)
arIDnrs = Array(0, 1, 1, 2, 1, 1, 3, 3, 1, 0, 0, 0, 0, 0, 0, 0)


Dim i As Long, j As Long, v As Variant, id As Long, idcnt As Long
Dim arValDiffs() As Currency, arTemp() As Double
Dim dicID_ValueDiffArray As New Dictionary  'key = IDnr, value = array that stores the values
Dim dicID_ValCount As New Dictionary        'key = IDnr, value = count of values
Dim dicID_ValCntHelper As New Dictionary    'key = IDnr, value = helpcounter

'create evenly sized array
ReDim arValDiffs(0 To ValCount)

'loop through all (millions of) Vals, filter out unique id-nrs (.item) and calculate and store amount of calls per idnr
For i = LBound(arValues) To ValCount
    'calculate Val-difference
    If i = LBound(arValues) Then
        arValDiffs(i) = 0
    Else
        arValDiffs(i) = (arValues(i) - arValues(i - 1))
    End If
    
    'extract (unique) used ID numbers and place in dictionary. dictionary-value = count of values of matching IDnr in arValues
    dicID_ValCount.Item(arIDnrs(i)) = dicID_ValCount.Item(arIDnrs(i)) + 1
Next i

'create an empty 1D-array per used ID and place in new dictionary
For Each v In dicID_ValCount.Keys()
    ReDim arTemp(1 To dicID_ValCount(v))
    dicID_ValueDiffArray.Item(v) = arTemp
Next v

'loop though (millions of)  Again, move ValDiffs from huge arValDiffs to ID-specific arrays and place in dicID_ValueDiffArray
For i = 1 To ValCount                       'loop all Vals
    id = arIDnrs(i)                         'id of current Val
    idcnt = dicID_ValCntHelper.Item(id) + 1 'add id to helper dic if doesnt exist and keep track of how many Vals are already stored
    dicID_ValCntHelper.Item(id) = idcnt     'store count of stored Vals in helper dictionary
    
    arTemp = dicID_ValueDiffArray(id)       'get arr out of dictionary (this extra step is necessary)
    arTemp(idcnt) = arValDiffs(i)           'store Val value in temp arr
    dicID_ValueDiffArray(id) = arTemp       'place temp arr back in the dict
Next i

Debug.Print JsonConverter.ConvertToJson(dicID_ValueDiffArray)
'prints  {"0":[0],"1":[10,20,30,40,50],"2":[11],"3":[1,2]}
End Sub

I'm not familiar yet with other .NET or VB6 arrays or collections but if there is a fast way to solve this with one of those functions, please tell me.

Answer 1

Private Function ToCollection(arValues() As Variant, arIDnrs() As Variant, ByVal ValCount As Long) As Collection
  Set ToCollection = New Collection
  
  Dim offset As Long
  For offset = 0 To ValCount - 1
    On Error GoTo new_item
    ToCollection.Item(LTrim$(Str$(arIDnrs(LBound(arIDnrs) + offset)))).Add arValues(LBound(arValues) + offset)
    On Error GoTo 0
  Next
  
  Exit Function
  
new_item:
  ToCollection.Add New Collection, LTrim$(Str$(arIDnrs(LBound(arIDnrs) + offset)))
  Resume
End Function

Private Function ToDictionary(arValues() As Variant, arIDnrs() As Variant, ByVal ValCount As Long) As Dictionary
  Set ToDictionary = New Dictionary
  
  Dim offset As Long
  For offset = 0 To ValCount - 1
    On Error GoTo new_item
    ToDictionary.Item(LTrim$(Str$(arIDnrs(LBound(arIDnrs) + offset)))).Add arValues(LBound(arValues) + offset)
    On Error GoTo 0
  Next
  
  Exit Function
  
new_item:
  Set ToDictionary.Item(LTrim$(Str$(arIDnrs(LBound(arIDnrs) + offset)))) = New Collection
  Resume
End Function

Dim arValues() As Variant, arIDnrs() As Variant, ValCount As Long

'incoming data to process
ValCount = 8
arValues = Array(0, 10, 30, 41, 71, 111, 112, 114, 164, 0, 0, 0, 0, 0, 0, 0)
arIDnrs = Array(0, 1, 1, 2, 1, 1, 3, 3, 1, 0, 0, 0, 0, 0, 0, 0)
  
Dim c As Collection
Set c = ToCollection(arValues, arIDnrs, ValCount)
  
Dim d As Dictionary
Set d = ToDictionary(arValues, arIDnrs, ValCount)