Question

首先，我想说，我已经在网上搜索过，但我还没有碰到这样的事情。我已经看到了集合或数组数组的集合，但没有看到数组的集合。

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

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

我想循环遍历C列并输入一个选择案例陈述来检查该类，然后将值分配给集合

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

顺便说一句，我找到了另一个解决方案，包括字典和三维数组。

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

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

2 个答案: