如何在 VBA 中合并两个数组？

Question

给定

Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant

arr1 = Array("A", 1, "B", 2)
arr2 = Array("C", 3, "D", 4)

问题

我可以对arr1 和arr2 执行什么样的操作并将结果分配给arr3 得到类似的结果：

arr3 = ("A", "C", 1, 3, "B", "D", 2, 4)

提示 （由于注释）：“1）arr1 中的元素是名称，arr2 中的元素是值，arr3 中的最终元素实际上是名称-值对，所以只要它们是成对的，我不在乎它们是否按顺序排列。”

Answer 1

试试这个：

arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",") 

Answer 2

不幸的是，VB6 中的 Array 类型没有那么多 razzmatazz 特性。您几乎将不得不遍历数组并将它们手动插入第三个

假设两个数组的长度相同

Dim arr1() As Variant
Dim arr2() As Variant
Dim arr3() As Variant

arr1() = Array("A", 1, "B", 2)
arr2() = Array("C", 3, "D", 4)

ReDim arr3(UBound(arr1) + UBound(arr2) + 1)

Dim i As Integer
For i = 0 To UBound(arr1)
    arr3(i * 2) = arr1(i)
    arr3(i * 2 + 1) = arr2(i)
Next i

更新：修正了代码。对不起以前的错误版本。我花了几分钟来访问一个 VB6 编译器来检查它。

Answer 3

此函数将按照 JohnFx 的建议执行，并允许数组的长度不同

Function mergeArrays(ByVal arr1 As Variant, ByVal arr2 As Variant) As Variant
    Dim holdarr As Variant
    Dim ub1 As Long
    Dim ub2 As Long
    Dim bi As Long
    Dim i As Long
    Dim newind As Long

        ub1 = UBound(arr1) + 1
        ub2 = UBound(arr2) + 1

        bi = IIf(ub1 >= ub2, ub1, ub2)

        ReDim holdarr(ub1 + ub2 - 1)

        For i = 0 To bi
            If i < ub1 Then
                holdarr(newind) = arr1(i)
                newind = newind + 1
            End If

            If i < ub2 Then
                holdarr(newind) = arr2(i)
                newind = newind + 1
            End If
        Next i

        mergeArrays = holdarr
End Function

Answer 4

我尝试了上面提供的代码，但它给了我一个错误 9。 我制作了这段代码，它可以很好地满足我的目的。我希望其他人也觉得它有用。

Function mergeArrays(ByRef arr1() As Variant, arr2() As Variant) As Variant

    Dim returnThis() As Variant
    Dim len1 As Integer, len2 As Integer, lenRe As Integer, counter As Integer
    len1 = UBound(arr1)
    len2 = UBound(arr2)
    lenRe = len1 + len2
    ReDim returnThis(1 To lenRe)
    counter = 1

    Do While counter <= len1 'get first array in returnThis
        returnThis(counter) = arr1(counter)
        counter = counter + 1
    Loop
    Do While counter <= lenRe 'get the second array in returnThis
        returnThis(counter) = arr2(counter - len1)
        counter = counter + 1
    Loop

mergeArrays = returnThis
End Function

Answer 5

如果 Lbound 不为 0 或 1 则有效。您在开始时 Redim 一次

Function MergeArrays(ByRef arr1 As Variant, ByRef arr2 As Variant) As Variant

'Test if not isarray then exit
If Not IsArray(arr1) And Not IsArray(arr2) Then Exit Function

Dim arr As Variant
Dim a As Long, b As Long 'index Array
Dim len1 As Long, len2 As Long 'nb of item

'get len if array don't start to 0
len1 = UBound(arr1) - LBound(arr1) + 1
len2 = UBound(arr2) - LBound(arr2) + 1

b = 1 'position of start index
'dim new array
ReDim arr(b To len1 + len2)
'merge arr1
For a = LBound(arr1) To UBound(arr1)
    arr(b) = arr1(a)       
    b = b + 1 'move index
Next a
'merge arr2
For a = LBound(arr2) To UBound(arr2)
    arr(b) = arr2(a)
    b = b + 1 'move index
Next a

'final
MergeArrays = arr

End Function

Answer 6

我的首选方式有点长，但比其他答案有一些优势：

• 一次可以合并不定数量的数组
• 它可以将数组与非数组（对象、字符串、整数等）组合起来
• 它说明了一个或多个数组可能包含对象的可能性
• 它允许用户选择新数组的基数（0、1 等）

这里是：

Function combineArrays(ByVal toCombine As Variant, Optional ByVal newBase As Long = 1)
'Combines an array of one or more 1d arrays, objects, or values into a single 1d array
'newBase parameter indicates start position of new array (0, 1, etc.)
'Example usage:
    'combineArrays(Array(Array(1,2,3),Array(4,5,6),Array(7,8))) -> Array(1,2,3,4,5,6,7,8)
    'combineArrays(Array("Cat",Array(2,3,4))) -> Array("Cat",2,3,4)
    'combineArrays(Array("Cat",ActiveSheet)) -> Array("Cat",ActiveSheet)
    'combineArrays(Array(ThisWorkbook)) -> Array(ThisWorkbook)
    'combineArrays("Cat") -> Array("Cat")

    Dim tempObj As Object
    Dim tempVal As Variant

    If Not IsArray(toCombine) Then
        If IsObject(toCombine) Then
            Set tempObj = toCombine
            ReDim toCombine(newBase To newBase)
            Set toCombine(newBase) = tempObj
        Else
            tempVal = toCombine
            ReDim toCombine(newBase To newBase)
            toCombine(newBase) = tempVal
        End If
        combineArrays = toCombine
        Exit Function
    End If

    Dim i As Long
    Dim tempArr As Variant
    Dim newMax As Long
    newMax = 0

    For i = LBound(toCombine) To UBound(toCombine)
        If Not IsArray(toCombine(i)) Then
            If IsObject(toCombine(i)) Then
                Set tempObj = toCombine(i)
                ReDim tempArr(1 To 1)
                Set tempArr(1) = tempObj
                toCombine(i) = tempArr
            Else
                tempVal = toCombine(i)
                ReDim tempArr(1 To 1)
                tempArr(1) = tempVal
                toCombine(i) = tempArr
            End If
            newMax = newMax + 1
        Else
            newMax = newMax + (UBound(toCombine(i)) + LBound(toCombine(i)) - 1)
        End If
    Next
    newMax = newMax + (newBase - 1)

    ReDim newArr(newBase To newMax)
    i = newBase
    Dim j As Long
    Dim k As Long
    For j = LBound(toCombine) To UBound(toCombine)
        For k = LBound(toCombine(j)) To UBound(toCombine(j))
            If IsObject(toCombine(j)(k)) Then
                Set newArr(i) = toCombine(j)(k)
            Else
                newArr(i) = toCombine(j)(k)
            End If
            i = i + 1
        Next
    Next

    combineArrays = newArr

End Function

Answer 7

不幸的是，与许多现代语言不同，如Java 或Javascript，没有办法使用VBA 在数组中追加/合并/插入/删除元素，而无需逐个元素地进行。

可以使用 split 和 join 来执行此操作，就像之前的答案所显示的那样，但这是一种缓慢的方法，而且不是通用的。

为了我个人的使用，我为一维数组实现了splice 函数，类似于 Javascript 或 Java。 splice 获取一个数组，并可以选择从给定位置删除一些元素，还可以选择在该位置插入一个数组

'*************************************************************
'*                      Fill(N1,N2)
'* Create 1 dimension array with values from N1 to N2 step 1
'*************************************************************
Function Fill(N1 As Long, N2 As Long) As Variant
Dim Arr As Variant
If N2 < N1 Then
  Fill = False
  Exit Function
End If
Fill = WorksheetFunction.Transpose(
          Evaluate("Row(" & N1 & ":" & N2 & ")"))
End Function
'**********************************************************************
'*                        Slice(AArray, [N1,N2])
'* Slice an array between indices N1 to N2
'***********************************************************************
Function Slice(VArray As Variant, Optional N1 As Long = 1, 
               Optional N2 As Long = 0) As Variant
Dim Indices As Variant
If N2 = 0 Then N2 = UBound(VArray)
If N1 = LBound(VArray) And N2 = UBound(VArray) Then
   Slice = VArray
Else
  Indices = Fill(N1, N2)
  Slice = WorksheetFunction.Index(VArray, 1, Indices)
End If
End Function
'************************************************
'*                 AddArr(V1,V2, [V3])
'* Concatena 2 ou 3 vetores
'**************************************************
Function AddArr(V1 As Variant, V2 As Variant, 
  Optional V3 As Variant = 0, Optional Sep = "#") As Variant
Dim Arr As Variant
Dim Ini As Integer
Dim N As Long, K As Long, I As Integer
  Arr = V1
  Ini = UBound(Arr)
  N = UBound(V1) - LBound(V1) + 1 + UBound(V2) - LBound(V2) + 1
  ReDim Preserve Arr(N)
  K = 0
  For I = LBound(V2) To UBound(V2)
    K = K + 1
    Arr(Ini + K) = V2(I)
  Next I
If IsArray(V3) Then
  Ini = UBound(Arr)
  N = UBound(Arr) - LBound(Arr) + 1 + UBound(V3) - LBound(V3) + 1
  ReDim Preserve Arr(N)
  K = 0
  For I = LBound(V3) To UBound(V3)
    K = K + 1
    Arr(Ini + K) = V3(I)
  Next I
End If
AddArr = Arr
End Function

'**********************************************************************
'*                        Slice(AArray,Ind, [ NElme, Vet] )
'* Delete NELEM (default 0) element from position IND in VARRAY
'* and optionally insert an array VET in that postion
'***********************************************************************
Function Splice(VArray As Variant, Ind As Long, 
  Optional NElem As Long = 0, Optional Vet As Variant = 0) As Variant
Dim V1, V2
If Ind < LBound(VArray) Or Ind > UBound(VArray) Or NElem < 0 Then
  Splice = False
  Exit Function
End If
V2 = Slice(VArray, Ind + NElem, UBound(VArray))
If Ind > LBound(VArray) Then
  V1 = Slice(VArray, LBound(VArray), Ind - 1)
  If IsArray(Vet) Then
     Splice = AddArr(V1, Vet, V2)
  Else
     Splice = AddArr(V1, V2)
  End If
Else
  If IsArray(Vet) Then
     Splice = AddArr(Vet, V2)
  Else
     Splice = V2
  End If
End If

End Function

用于测试

Sub TestSplice()
Dim V, Res
Dim J As Integer
V = Fill(100, 109)
Res = Splice(V, 2, 2, Array(201, 202))
PrintArr (Res)
End Sub

'************************************************
'*                 PrintArr(VArr)
'* Print the array VARR
'**************************************************
Function PrintArr(VArray As Variant)
Dim S As String
S = Join(VArray, ", ")
MsgBox (S)
End Function

结果

100,201,202,103,104,105,106,107,108,109

Answer 8

遵循@johannes 解决方案，但在不丢失数据的情况下合并（它缺少第一个元素）：

    Function mergeArrays(ByRef arr1() As Variant, arr2() As Variant) As Variant

    Dim returnThis() As Variant
    Dim len1 As Integer, len2 As Integer, lenRe As Integer, counter As Integer
    len1 = UBound(arr1)
    len2 = UBound(arr2)
    lenRe = len1 + len2 + 1
    ReDim returnThis(0 To lenRe)
    counter = 0

    For counter = 0 To len1 'get first array in returnThis
        returnThis(counter) = arr1(counter)
    Next


    For counter = 0 To len2 'get the second array in returnThis
        returnThis(counter + len1 + 1) = arr2(counter)
    Next
mergeArrays = returnThis
End Function

Answer 9

要连接 Array1 和 Array2，请创建一个新数组，例如 JointArray

Dim JointArray As Variant
ReDim JointArray(UBound(Array1) + UBound(Array2) + 1) As Variant
For i = 0 To UBound(JointArray)
    If i <= UBound(Array1) Then
    JointArray(i) = Array1(i)
    Else
    JointArray(i) = Array2(i - UBound(Array1) - 1)
    End If
Next

Answer 10

我想改编 user3286479 的好主意来处理来自单列范围的数组：

Dim ws As Worksheet
Set ws = ActiveSheet
arr1 = ws.Range("A2:A10").Value2
arr2 = ws.Range("B2:B6").Value2
    
arr3 = Split(Join(Application.Transpose(arr1), ",") & "," & Join(Application.Transpose(arr2), ","), ",")

Answer 11

这是一个使用集合对象组合两个一维数组并传递它们的版本 到第三个数组。不适用于多维数组。

Function joinArrays(arr1 As Variant, arr2 As Variant) As Variant
 Dim arrToReturn() As Variant, myCollection As New Collection
 For Each x In arr1: myCollection.Add x: Next
 For Each y In arr2: myCollection.Add y: Next

 ReDim arrToReturn(1 To myCollection.Count)
 For i = 1 To myCollection.Count: arrToReturn(i) = myCollection.Item(i): Next
 joinArrays = arrToReturn
End Function

Answer 12

Function marr(arr1 As Variant, arr2 As Variant) As Variant
Dim item As Variant
    For Each item In arr1
        i = i + 1
    Next item
    For Each item In arr2
        i = i + 1
    Next item
ReDim MergeData(0 To i)
i = 1
    For Each item In arr1
        MergeData(i) = item
        i = i + 1
    Next item
    For Each item In arr2
        MergeData(i) = item
        i = i + 1
    Next item
    marr = MergeData
End Function

Answer 13

或者甚至是任何一个变量都可以未初始化或空数组或对象数组（例如字典对象）的方式。不过，一次只能处理一个维度。此外，它将 arr2 附加到 arr1 而不是合并。

Function appendArray(ByVal arr1 As Variant, ByVal arr2 As Variant) As Variant
    Dim holdarr As Variant
    Dim ub1 As Long
    Dim ub2 As Long
    Dim i As Long
    Dim newind As Long

                            ' Allows for one or both variants to not be arrays
    If IsEmpty(arr1) Or Not IsArray(arr1) Then
        arr1 = Array()
    End If

    If IsEmpty(arr2) Or Not IsArray(arr2) Then
        arr2 = Array()
    End If
                            ' Now we assume we DO have two ARRAYS, even if one or the other
                            ' has no elements
    ub1 = UBound(arr1)
    ub2 = UBound(arr2)

    If ub1 = -1 Then
        appendArray = arr2
        Exit Function
    End If

    If ub2 = -1 Then
        appendArray = arr1
        Exit Function
    End If

            ' Copy the first array. We know it is not empty.
    holdarr = arr1

            ' Grow it to the final size we need, keeping the current contents
    ReDim Preserve holdarr(ub1 + ub2 + 1)

            ' Set the starting new index
    newind = UBound(arr1) + 1

            ' Append the second array, allowing that it might be an array of objects
    For i = 0 To ub2
        If VarType(arr2(i)) = vbObject Then
            Set holdarr(newind) = arr2(i)
        Else
            holdarr(newind) = arr2(i)
        End If
        newind = newind + 1
    Next i
            ' Return the appended array
    appendArray = holdarr
End Function

Answer 14

我非常感谢 Buggabill 和 Daniel McCracken 的回复。我需要一个函数来组合多维数组，但我相信我将来会使用 Daniel 的。我对 Buggabill 进行了一些修改，以 1) 容纳混合了变量和对象的多维数组，以及 2) 按顺序合并两个数组而不是网格在一起（因为这两个数组在 For 循环的每个步骤中组合在一起）。有关说明，请参见下面的 Was/Now 示例。

Function mergeArrays(ByVal arr1 As Variant, ByVal arr2 As Variant) As Variant
'Appends arr2 to arr1.
'Ex: mergeArrays(Array(0,1,2,3),Array(4,5,6,7)) = Array(0,1,2,3,4,5,6,7)
'Was: mergeArrays(Array(0,1,2), Array(Array(4, Object5, Object6), _
                                      Array(7, Object8, Object9)) = _
      = Array(Array(0,1,2),4,7,Object5,Object8,Object6,Object9)
'Now: = Array(Array(0,1,2), _
              Array(4, Object5, Object6), _
              Array(7, Object8, Object9))

'Source: Buggabill, https://stackoverflow.com/questions/1588913/how-do-i-merge-two-arrays-in-vba
    
    Dim holdarr As Variant, ub1 As Long, ub2 As Long, bi As Long, i As Long, newind As Long

    ub1 = UBound(arr1) + 1 
    ub2 = UBound(arr2) + 1

    bi = IIf(ub1 >= ub2, ub1, ub2)

    ReDim holdarr(ub1 + ub2 - 1)

    For i = 0 To bi
        If i < ub1 Then
            If IsObject(arr1(i)) Then
                Set holdarr(newind) = arr1(i)
            Else
                holdarr(newind) = arr1(i)
            End If
            newind = newind + 1
        ElseIf i < ub2 + ub1 Then
            If IsObject(arr2(i - ub1)) Then
                Set holdarr(newind) = arr2(i - ub1)
            Else
                holdarr(newind) = arr2(i - ub1)
            End If
            newind = newind + 1
        End If
    Next i
    
    mergeArrays = holdarr
End Function

希望这对你们中的一些人有所帮助。

Answer 15

使用ArrayToText() 函数扩展Split approach (MS365)

如果您弃用 MS/Excel 365，您可以通过传递所谓的 锯齿状数组 来简化连接和拆分 （请参阅 @user3286479 最受好评的 post ） （也称为数组数组） 作为主要参数。这个锯齿状数组可能包含两个甚至更多个数组，而不仅仅是arr1和arr2。

作为进一步的好处，我包括了决定数组是否返回合并数组元素的选项连续（默认值additive=True）或不（即与显式参数additive=False交织在一起）。

Function MergeArr(jagged As Variant, _
         Optional ByVal additive As Boolean = True)
'Note: returns only string elements (needs arrays of same length)
    If additive Then    ' all elems of 1st array, then all elems of 2nd one etc.
        MergeArr = Split(Application.ArrayToText(jagged), ", ")
    Else                ' intertwine first elems of each array, then all second elems etc.
        MergeArr = Split(Application.ArrayToText(Application.Transpose(jagged)), ", ")
    End If
End Function

调用示例

Sub testMergeArr()
    Dim arr1 As Variant
    arr1 = Array("A", 1, "B", 2)
    Dim arr2 As Variant
    arr2 = Array("C", 3, "D", 4)

    Dim arr3 As Variant

    arr3 = MergeArr(Array(arr1, arr2))
    Debug.Print "additive   ~~> " & Application.ArrayToText(arr3)

    arr3 = MergeArr(Array(arr1, arr2), False)
    Debug.Print "alternating ~~> " & Application.ArrayToText(arr3)
End Sub

VB 编辑器的即时窗口中的结果

    additive    ~~> A, 1, B, 2, C, 3, D, 4
    alternating ~~> A, C, 1, 3, B, D, 2, 4

警告

上述方法的一个可能缺点是所有元素都将作为字符串返回，因此也包括所有数值。为了避免这种情况，您可以使用以下函数或者使用FilterXML()（从 2013 年版本开始提供）：

Function MergeArrXML(jagged As Variant, _
         Optional ByVal additive As Boolean = True)
'Note: allows to maintain not only string elements, but also numeric values (doubles)
    Dim content As String
    If additive Then    ' all elems of 1st array, then all elems of 2nd one etc.
        content = Replace(Application.ArrayToText(jagged), ", ", "</i><i>")
    Else                ' intertwine first elems of each array, then all second elems etc.
        content = Replace(Application.ArrayToText(Application.Transpose(jagged)), ", ", "</i><i>")
    End If
    MergeArrXML = Application.Transpose(Application.FilterXML("<r><i>" & content & "</i></r>", "//i"))
End Function

Answer 16

Sub MergeArraysTest()

    Dim I As Long
    Dim Arr1(3) As Double
    Dim Arr2(5) As Double
    Dim MrgArr() As Double

    Arr1(0) = 123.456
    Arr1(1) = 123.456
    Arr1(2) = 123.456
    Arr1(3) = 123.456

    Arr2(0) = 789.101112
    Arr2(1) = 789.101112
    Arr2(2) = 789.101112
    Arr2(3) = 789.101112
    Arr2(4) = 789.101112
    Arr2(5) = 789.101112

    MrgArr = MergeArraysDataTypeDouble(Arr1, Arr2)

    For I = LBound(MrgArr) To UBound(MrgArr) Step 1
        Debug.Print "***" & MrgArr(I) & "***"
    Next

End Sub

    Public Function MergeArraysDataTypeDouble(Array1() As Double, Array2() As Double) As Double()

        Dim I As Long
        Dim J As Long
        Dim MergedArray() As Double
        ReDim MergedArray(UBound(Array1) + UBound(Array2) + 1)

        For I = LBound(MergedArray) To UBound(MergedArray) Step 1
            If I <= UBound(Array1) Then
                MergedArray(I) = Array1(I)
            ElseIf I > UBound(Array1) Then
                MergedArray(I) = Array2(J)
                J = J + 1
            End If
        Next
        MergeArraysDataTypeDouble = MergedArray

    End Function

Answer 17

这是我的版本。

• 任意长度
• 任何数据类型
• 浅拷贝，但适用于 Array() 元素

Sub ArrayCat(ByRef arr1, ByRef arr2)
    Dim newLen As Integer, idx1 As Integer, idx2 As Integer
    idx1 = UBound(arr1) + 1
    newLen = UBound(arr1) + UBound(arr2) + 1
    ReDim Preserve arr1(newLen)
    idx2 = 0
    For idx1 = idx1 To newLen
        arr1(idx1) = arr2(idx2)
        idx2 = idx2 + 1
    Next idx1
End Sub