Question

我正在尝试使用以下代码使用来自现有二维数组的值的唯一键填充Final数组：最终数组有3个Data维度，我希望数组看起来像这样：

Finalarray（0）：{a，1,4,8} ...... Finalarray（4）：{e，空，空，12}

我的代码使用键，即a，b，c，d，e来初始化上面的数组，但是，我不确定最常用的填充方法是什么！

假设每个“a”条目都是新行

我目前正在尝试的尝试（但非常手动）只是为了选择“e”：

    Sub ArrayTest()
    Dim PreservedKeys As Variant
    Dim Data(0 To 2, 0 To 3) As Variant
    Dim rRef As Range
    Dim PreservedData As Variant
    Dim MergedArray As Variant
    Dim i As Integer
    Dim uniquePreservedKeys As Variant

    Dim FinalArray
    Dim Constant As Integer

    PreservedKeys = Array("a", "b", "c", "a", "b", "c", "d", "a", "b", "c", "d", "e")
    PreservedData = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    Constant = 3


    ReDim MergedArray(0 To UBound(PreservedKeys), 0 To 1)

      For i = 0 To UBound(PreservedKeys)

        MergedArray(i, 0) = PreservedKeys(i)
        MergedArray(i, 1) = PreservedData(i)

      Next i


    uniquePreservedKeys = M_snb(PreservedKeys)

    ReDim FinalArray(0 To UBound(uniquePreservedKeys), 0 To Constant)

    For i = 0 To 4
        FinalArray(i, 0) = uniquePreservedKeys(i)
    Next i



    Set rRef = Application.Range("TestRange")

    rRef.Resize(UBound(Data, 1) + 1, UBound(Data, 2) + 1) = Data

    'MY ATTEMPT SO FAR --> Very manual to just get the e entry
        If MergedArray(i, 0) = "a" Then
            counter = counter + 1
        End If

     If counter = 1 Then
       If MergedArray(i, 0) <> "e" Then
           FinalArray(4, counter) = ""
       Else
        FinalArray(4, counter) = MergedArray(i, 1)
       End If
     End If

      If counter = 3 Then
       If MergedArray(i, 0) <> "e" Then
           FinalArray(4, counter) = ""
       Else
        FinalArray(4, counter) = MergedArray(i, 1)
       End If
     End If


     Next i


    End Sub


 Function M_snb(UniqueKeys As Variant)
        With CreateObject("scripting.dictionary")
            For Each it In UniqueKeys
                c10 = .Item(it)
            Next
            an = .keys ' the array .keys contains all unique keys

        End With

    M_snb = an

    End Function

Answer 1

Sub ArrayTest()
Dim PreservedKeys As Variant
Dim Data(0 To 2, 0 To 3) As Variant
Dim rRef As Range
Dim PreservedData As Variant
Dim MergedArray As Variant
Dim i As Integer
Dim uniquePreservedKeys As Variant

Dim FinalArray
Dim Constant As Integer

PreservedKeys = Array("a", "b", "c", "a", "b", "c", "d", "a", "b", "c", "d", "e")
PreservedData = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
Constant = 3


ReDim MergedArray(0 To UBound(PreservedKeys), 0 To 1)

  For i = 0 To UBound(PreservedKeys)

    MergedArray(i, 0) = PreservedKeys(i)
    MergedArray(i, 1) = PreservedData(i)

  Next i


uniquePreservedKeys = M_snb(PreservedKeys)

ReDim FinalArray(0 To UBound(uniquePreservedKeys), 0 To Constant)

For i = 0 To 4
    FinalArray(i, 0) = uniquePreservedKeys(i)
Next i


For i = 0 To UBound(FinalArray)
counter = 0
 For k = 0 To UBound(MergedArray)


    If MergedArray(k, 0) = "a" Then
        counter = counter + 1
    End If
    If MergedArray(k, 0) <> FinalArray(i, 0) Then
       GoTo Label
    Else
    FinalArray(i, counter) = MergedArray(k, 1)
    End If

Label:
 Next k
Next i


Set rRef = Application.Range("TestRange")

rRef.Resize(UBound(FinalArray, 1) + 1, UBound(FinalArray, 2) + 1) = FinalArray



End Sub

Function M_snb(UniqueKeys As Variant)
    With CreateObject("scripting.dictionary")
        For Each it In UniqueKeys
            c10 = .Item(it)
        Next
        an = .keys ' the array .keys contains all unique keys

    End With

M_snb = an

End Function

VBA从另一个数组填充数组

1 个答案: