将集合的值复制到 VBA 中的二维数组 [英] Copy the values of a collection to a 2D array in VBA

问题描述

I seem to be banging my ahead against the proverbial brick wall. I have a loop which runs and populates a collection. There are approximately 20000 rows and 11 columns. I need to be able to get the contents of the collection into a variant array so that I can do a bulk copy to a worksheet. The reason I was using a collection is for the inherent de-duplication of entries.

Please could someone offer a suggestion as to how to achieve this. I assume I am missing something straightforward but if I dont use a collection I need to dedupliate 200k+ rows.

Thanks in advance for all your help

EDIT

Here is the actual code. As I mentioned above, the problem is not getting the data into the collection (MyCollection), its getting it out again!

EDIT

The flow of data starts in a worksheet which is then copied into an array called ArrayOrg. The array is looped through and when certain conditions are satisfied, a record is added to the ArrayOrg1 array. Please see the code below.

    For intI = 1 To UBound(ArrayOrg())
            If ArrayOrg(intI, 7) = "cMat" And ArrayOrg(intI, 5) = "Plant" Then

                ArrayOrg1_cMat(Org1Count_cMat, 0) = ArrayOrg(intI, 1)           'User ID
                ArrayOrg1_cMat(Org1Count_cMat, 1) = ArrayOrg(intI, 2)           'BR ID
                ArrayOrg1_cMat(Org1Count_cMat, 2) = ArrayOrg(intI, 3)           'Scenario
                ArrayOrg1_cMat(Org1Count_cMat, 3) = ArrayOrg(intI, 4)           'Role
                ArrayOrg1_cMat(Org1Count_cMat, 4) = ArrayOrg(intI, 5)           'Controlling Field
                ArrayOrg1_cMat(Org1Count_cMat, 5) = ArrayOrg(intI, 6)           'Controlling Field Value
                ArrayOrg1_cMat(Org1Count_cMat, 6) = ArrayOrg(intI, 7)           'Webapp
                Org1Count_cMat = Org1Count_cMat + 1
Next intI

Dim MyCollection As Collection
    Dim ArrayTemp() As Variant
    Set MyCollection = New Collection  

    For intI = 0 To UBound(ArrayOrg1_cMat())
        For intJ = 0 To UBound(ArrayOrg2_cMat())
                If ArrayOrg2_cMat(intJ, 0) = ArrayOrg1_cMat(intI, 0) Then
                        If ArrayOrg2_cMat(intJ, 1) = ArrayOrg1_cMat(intI, 1 Then                             If ArrayOrg2_cMat(intJ, 2) = ArrayOrg1_cMat(intI, 2) Then                                 If ArrayOrg2_cMat(intJ, 3) = ArrayOrg1_cMat(intI, 3) Then                                     

                                    ArrayTemp(0, 0) = ""                                    'Name
                                    ArrayTemp(0, 1) = ArrayOrg1_cMat(intI, 0)               'AD ID
                                    ArrayTemp(0, 2) = ""                                    'Email
                                    ArrayTemp(0, 3) = ""                                     'Requester
                                    ArrayTemp(0, 4) = ArrayOrg1_cMat(intI, 6)               'Webapp
                                    ArrayTemp(0, 5) = ArrayOrg1_cMat(intI, 2)               'Scenario
                                    ArrayTemp(0, 6) = ArrayOrg1_cMat(intI, 3)               'Role
                                    ArrayTemp(0, 7) = "PL"                                 'Business Unit
                                    ArrayTemp(0, 8) = "NONE"
                                    ArrayTemp(0, 9) = "NONE"
                                    ArrayTemp(0, 10) = "NONE"
                                    ArrayTemp(0, 11) = ArrayTemp(0, 0) & ArrayTemp(0, 1) & ArrayTemp                                              (0, 2) & ArrayTemp(0, 3) & ArrayTemp(0, 4) _
                                                      & ArrayTemp(0, 5) & ArrayTemp(0, 6) & ArrayTemp                                                 (0, 7) & ArrayTemp(0, 8) & ArrayTemp(0, 9) _
                                                      & ArrayTemp(0, 10) '### This is the key for the collection

                                    On Error Resume Next
                                    MyCollection.Add ArrayTemp, ArrayTemp(0, 11)
                                    On Error GoTo 0                                    
                                End If
                            End If
                        End If
                End If
        Next intJ
    Next intI
'#### THIS IS WHERE THE PROBLEM IS
For intI = 0 To MyCollection.Count  
    ArrayOutput(intI, 0) = MyCollection.Item(intI)  
Next intI  

Thanks Kevin

解决方案

Sub Tester()

Dim k As String
Dim i As Long, j As Long, r As Long, x As Long
Dim arr() As Variant
Dim dict

    ReDim arr(1 To UBound(ArrayOrg1_cMat, 1) + 1, 1 To 11)
    r = 0
    Set dict = CreateObject("scripting.dictionary")

    For i = 0 To UBound(ArrayOrg1_cMat())
        For j = 0 To UBound(ArrayOrg2_cMat())

            If ArrayOrg2_cMat(j, 0) = ArrayOrg1_cMat(i, 0) Then
            If ArrayOrg2_cMat(j, 1) = ArrayOrg1_cMat(i, 1) Then
            If ArrayOrg2_cMat(j, 2) = ArrayOrg1_cMat(i, 2) Then
            If ArrayOrg2_cMat(j, 3) = ArrayOrg1_cMat(i, 3) Then

                ' I'm skipping the constant values in your original key...
                k = Join(Array(ArrayOrg1_cMat(i, 0), _
                               ArrayOrg1_cMat(i, 6), _
                               ArrayOrg1_cMat(i, 2), _
                               ArrayOrg1_cMat(i, 3)), "~")

                If Not dict.exists(k) Then
                    r = r + 1
                    dict.Add k, True
                    arr(r, 1) = ""                   'Name
                    arr(r, 2) = ArrayOrg1_cMat(i, 0) 'AD ID
                    arr(r, 3) = ""                   'Email
                    arr(r, 4) = ""                   'Requester
                    arr(r, 5) = ArrayOrg1_cMat(i, 6) 'Webapp
                    arr(r, 6) = ArrayOrg1_cMat(i, 2) 'Scenario
                    arr(r, 7) = ArrayOrg1_cMat(i, 3) 'Role
                    arr(r, 8) = "PL"                 'Business Unit
                    arr(r, 9) = "NONE"
                    arr(r, 10) = "NONE"
                    arr(r, 11) = "NONE"
                End If


            End If
            End If
            End If
            End If

        Next j
    Next i

    ActiveSheet.Range("a2").Resize(r, 11).Value = arr

End Sub

这篇关于将集合的值复制到 VBA 中的二维数组的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！