Styjun

I have a dictionary and want to add new strings to the items. My idea is to create a list of strings as item for each key.

My code is so far:

Sub AccountEntitlements()

 Dim sh1 As Worksheet
 Dim acc As Worksheet
 Dim arr() As Variant
 Dim d As Variant
 Dim i As Long
 Dim count As Long

 Set sh1 = Sheets("Sheet1")
 Set acc = Sheets("accountsentitlements")
 Set d = CreateObject("Scripting.Dictionary")

 arr = sh1.Range("D:F")

 For i = LBound(arr) To UBound(arr)
 If d.Exists(arr(i, 3)) Then
 ReDim Preserve arr(UBound(arr) + 1) '<- Error line
 d(arr(i, 3)) = Array(arr(i, 1))
 Else
 d.Add Key:=arr(i, 3), Item:=Array(arr(i, 1))
 End If

 Next i

 For count = 1 To d.count - 1
 acc.Cells(count + 1, "D").Value = UCase(d.Keys()(count))
 acc.Cells(count + 1, "E").Value = d.Items()(count)
 Next count

End Sub

The error message is Run-time error '9': Subscript out of range.

The important code block is

For i = LBound(arr) To UBound(arr)
 If d.Exists(arr(i, 3)) Then
 ReDim Preserve arr(UBound(arr) + 1) '<- Error line
 d(arr(i, 3)) = Array(arr(i, 1))
 Else
 d.Add Key:=arr(i, 3), Item:=Array(arr(i, 1))
 End If

The key of a dictionary is the user account and the items should be their membership groups.
Example:

Key= ABCD , Item= Entitlement1, Entitlement2, etc.

How can the item array be extended and include previous entries?

Among other problems:

You can only ReDim the last element of a multi-dimensional array.

Your line

arr = sh1.Range("D:F")

will create a 1-based 2D array: arr(1 to 1048576, 1 to 4). If you have a database with over 4*10^6 elements, you might want to consider a different tool.

So a valid command might be

Redim Preserve arr(1 to ubound(arr,1), 1 to ubound(arr,2)+1)

But that's not what your doing. To accomplish what you want to do, try something like this:

For i = LBound(arr) To UBound(arr)
 If d.Exists(arr(i, 3)) Then
 X = d(arr(i, 3))
 ReDim Preserve X(UBound(X, 1) + 1)
 X(UBound(X, 1)) = arr(i, 1)
 d(arr(i, 3)) = X
 Else
 d.Add Key:=arr(i, 3), Item:=Array(arr(i, 1))
 End If 
Next i

But why not just use a Dictionary or Collection to hold your list of items. Then you don't have to worry at all about resizing your array.

Thank you very much for your assistance (@Ron Rosenfeld)!

Below is my final code part.

For i = LBound(arr) To UBound(arr)
 If d.Exists(arr(i, 3)) Then
 d(arr(i, 3)) = d.Item(arr(i, 3)) & "," & arr(i, 1)
 Else
 d.Add Key:=arr(i, 3), Item:=arr(i, 1)
 End If
Next i

I was still testing whether I should concatenate the strings with & "," & or with the JOIN() function but decided eventually for the first option.

Regarding my array size, I added a row counter to fit the length of the array. lrow = sh1.Cells(Rows.count, "D").End(xlUp).Row.