Добавить элементы в массив в словаре

У меня есть словарь, и я хочу добавить новые строки к элементам. Моя идея состоит в том, чтобы создать список строк как item для каждого key.

Мой код до сих пор:

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

сообщение об ошибке — это Run-time error '9': Subscript out of range.

Важным блоком кода является

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

Ключ словаря — это учетная запись пользователя, а элементы должны быть их группами членства. Пример:

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

Как можно расширить массив элементов и включить в него предыдущие записи?