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

Question

У меня есть словарь, и я хочу добавить новые строки в элементы. Моя идея состоит в том, чтобы создать список строк как 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

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

Ключ = ABCD, Предмет = Право1, Право2 и т. Д.

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

Answer 1

Среди других проблем:

Вы можете только ReDim последний элемент многомерного массива.

Ваша строка

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

создаст 12D-массив на основе: arr(1 to 1048576, 1 to 4).Если у вас есть база данных с более чем 1010 * элементами, вы можете рассмотреть возможность использования другого инструмента.

Таким образом, допустимая команда может быть

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

Но это не то, что вы делаете.Чтобы выполнить то, что вы хотите сделать, попробуйте что-то вроде этого:

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

Но почему бы просто не использовать Dictionary или Collection для хранения вашего списка предметов.Тогда вам не нужно беспокоиться об изменении размера вашего массива.

Answer 2

Большое спасибо за вашу помощь (@Ron Rosenfeld)!

Ниже моя последняя часть кода.

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

Я все еще проверял, следует ли мне объединять строки с помощью & "," & или с помощью функции JOIN(), но в конце концов определился с первым вариантом.

Что касается размера моего массива, я добавил счетчик строк, чтобы соответствовать длине массива. lrow = sh1.Cells(Rows.count, "D").End(xlUp).Row.