是否可以在 vba 中创建数组集合？

Question

首先，我想说，我已经通过网络搜索过，但我还没有遇到过这样的事情。我见过集合的集合，或数组的数组，但不是数组的集合。

我想要做的是，收集每个区的集合中的 ID。最后，我将使用 Join 函数和“;”加入集合中的值作为分隔符，然后在每个类的 4 列范围内打印它们作为查找列表。例如;

Class2(0) 将包括 54020 和 30734，class2(1) 将包括 58618，class1(4) 将包括 none，class3(7) 将包括 35516、34781 和 56874，依此类推。

我想遍历 C 列并放置一个 select case 语句来检查类，然后将值分配给集合

Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection

Dim dict As New Scripting.Dictionary

Set dRange = range(range("a2"), range("a2").End(xlDown))

i = 0
For Each d In dRange
    If Not dict.Exists(d.Value) Then
        dict.Add key:=d.Value, item:=i
        i = i + 1
    End If
Next d

Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
    Select Case c.Value
        Case "class1"
            class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
        Case "class2"
            class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
        Case "class3"
            class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
        Case Else
            class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
    End Select
Next c
End Sub

我想看到的是如下： 我想做的事情有什么更简单和正确的方法吗？任何帮助将不胜感激。

谢谢

Answer 1

我没有看到您的代码中定义的 sb 变量。

无论如何，对我来说，我看到了一个简单数组的例子：类的维度是固定的，所以对我来说已经足够好了。此外，您可以轻松地打印回工作表。

Public Sub test()

  Const strPrefix = "class"

  Dim districtRange As Range, outputRange As Range, r As Range
  Dim arr() As String
  Dim i As Long, j As Long, x As Long, y As Long
  Dim district As String, str As String, idVal As String

  Dim arr2 As Variant

  Application.ScreenUpdating = False

  ReDim arr(1 To 5, 1 To 1)
  arr(1, 1) = "District"
  arr(2, 1) = "Class 1"
  arr(3, 1) = "Class 2"
  arr(4, 1) = "Class 3"
  arr(5, 1) = "Class 4"

  Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
  arr2 = districtRange.Value
  For x = LBound(arr2, 1) To UBound(arr2, 1)
        district = arr2(x, 1)
        i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
        idVal = arr2(x, 2)
        j = inArray(arr, district, 1)       'returns -1 if not found
        If j >= 0 Then
              arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
        Else
              ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
              arr(1, UBound(arr, 2)) = district
              arr(i + 1, UBound(arr, 2)) = idVal
        End If
  Next x

  Set outputRange = Range("E1")
  outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
  outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending

  Application.ScreenUpdating = True
End Sub

Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long

  Dim i As Long, j As Long
  inArray = -1

  If rowNum Then
        For i = LBound(arr, 2) To UBound(arr, 2)
              If arr(rowNum, i) = k Then
                    inArray = i
                    Exit Function
              End If
        Next i
  Else
        For i = LBound(arr, 1) To UBound(arr, 1)
              If arr(i, colNum) = k Then
                    inArray = i
                    Exit Function
              End If
        Next i
  End If
End Function

Answer 2

顺便说一句，我找到了另一种解决方案，同时使用字典和 3 维数组。

Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String

ReDim Siciller(0 To 23, 0 To 3, 0 To 5)

Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))

i = 0
For Each d In alanBolge
    If Not Blg.Exists(d.Value) Then
        Blg.Add Key:=d.Value, item:=i
        i = i + 1
    End If
Next d

k = 0
For Each d In alanSegment
    If Not Sgm.Exists(d.Value) Then
        Sgm.Add Key:=d.Value, item:=k
        k = k + 1
    End If
Next d



'data reading
For Each d In alanBolge
    Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d


'output
For x = 1 To 4
    For y = 1 To 24
        Set h = Cells(1 + y, 5 + x)
        h.Select
        h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
    Next y
Next x


End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
    Dim count As Integer
    count = 0

    For j = 0 To UBound(data, 3) - 1
        If Len(data(i1, i2, j)) > 0 Then
            count = count + 1
        End If
    Next
    dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
    sonucgetir = ""
    For i = 0 To UBound(data, 3)
        If Len(data(i1, i2, i)) > 0 Then
            x = data(i1, i2, i) & ";" & x
            sonucgetir = Left(x, Len(x) - 1)
        End If
    Next i
End Function