动态创建集合 VBA 的集合

Question

我正在尝试动态创建一个包含嵌套集合的集合。到目前为止，我已经能够通过键入所有内容来创建嵌套集合（见下文）。

但是，我有一个 (horrible) 电子表格，其中有一组重复的 17 个问题在一个列中数百次，而答案在下一列中。我试图将每个问题的答案作为一个项目，并将问题本身作为索引。 17 个问题的独特集合将是整个电子表格集合中的一个集合。如果这没有意义，请考虑为集合中的每个项目创建一个集合。

这是手动输入的集合集合：

谢谢！

Sub test()
Dim M As New Collection

Dim nst3 As New Collection
Dim nst2 As New Collection
Dim nst1 As New Collection

Dim i As Integer
Dim ii As Integer

nst1.Add "A", "1"
nst1.Add "B", "2"
nst1.Add "C", "3"
nst1.Add "D", "4"

nst2.Add "E", "1"
nst2.Add "F", "2"
nst2.Add "G", "3"
nst2.Add "H", "4"

nst3.Add "I", "1"
nst3.Add "J", "2"
nst3.Add "K", "3"
nst3.Add "L", "4"

M.Add nst1, "Nested_Collection_A"
M.Add nst2, "Nested_Collection_B"
M.Add nst3, "Nested_Collection_C"


For i = 1 To M.Count
    For ii = 1 To M(i).Count
        Debug.Print M(i)(ii)
    Next ii
Next i

End Sub

编辑：

在 D 列中，我将这些值重复一遍又一遍，次数不定。 E 列有响应。

Date posting/bagging will end?(R)
Date to post/bag location(s)s or meter(s)?(R)
Location 1:
Location 2:
Location 3:
Location 4:
Location 5:
Location 6:
Purpose of Posting/Bagging?
Service Request is from an AMENDED permit(R)?
Side of street to Post/Bag?(R)
Special instructions to Bureau of Traffic Services?
Time posted/bagged begins?(R)
Time posted/baggged ends?(R)
Type of action required?(R)

我试图收集每个问题是索引，每个答案是项目的集合。

然后，我需要每个集合的集合。

Answer 1

我会考虑使用 Dictionary 的集合，因为使用标准 VBA 集合是不可能检索键列表的。 假设您有关于 Col A 的问题列表和关于 Col B 的答案，您可以执行以下操作：

Sub ReadQuestions()

    Row = 1

    Dim QA As Object
    Set QA = CreateObject("Scripting.Dictionary")

    Dim Ans As Collection

    Do
        'Get Q & A for current row
        question = Cells(Row, 1).text
        answer = Cells(Row, 2).text

        'Tests if last filled row
        If question = "" Then Exit Do

        'If question is duplicate append answer to the current answer collection for that question
        If QA.Exists(question) Then
            QA(question).Add answer
        'If new question, add a collection of answers with one member (so far) to it
        Else
            Set Ans = New Collection
            Ans.Add answer
            Set QA(question) = Ans
        End If

        Row = Row + 1
    Loop

    Set Ans = Nothing


    'Now a simple test

    'Notice that Dictionnary.Keys() is a zero-based array
    FirstQuestion = QA.Keys()(0)
    NAnswers = QA(FirstQuestion).Count
    'On the other hand, Collections are one-based
    FirstAnswer = QA(FirstQuestion).Item(1)

    MsgBox "First question '" & FirstQuestion & "' has " & NAnswers & " answers. The first answer is '" & FirstAnswer & "'"

End Sub