18

Given

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

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

Question

What kind of operations can I perform on arr1 and arr2 and assign the result to arr3 getting something like that:

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

Hint (due to comment): "1) the elements in arr1 are names and in arr2 are values, the final elements in arr3 are actually name-value pairs, so as long as they as paired I won't care if they are not in order."

T.M.
  • 9,436
  • 3
  • 33
  • 57
Kevin Boyd
  • 12,121
  • 28
  • 86
  • 128
  • Two questions: (1) Is the order of elements in the merged array important? (2) Do you want to eliminate dupes if the same value appears in both arrays? – JohnFx Oct 19 '09 at 14:26
  • 1) the elements in arr1 are names and in arr2 are values the final elements in arr3 are actually name value pairs so as long as they as paired I wont care if they are not in order. Hope that answers your question. 2) I think point 1 answered this, I will be taking care of dupe names eleswhere. – Kevin Boyd Oct 19 '09 at 14:30

17 Answers17

22

Try this:

arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",") 
user3286479
  • 415
  • 3
  • 15
  • 26
  • 1
    For in case, the arrays contain a comma, can use `Split(Join(arr1, Chr(1)) & Chr(1) & Join(arr2, Chr(1)), Chr(1))` – Malan Kriel Mar 04 '20 at 07:15
  • Fyi Posted an extension to your fine solution, using the new `ArrayToText()` function and allowing to return numeric values as further benefit. @user3286479 – T.M. Dec 26 '21 at 21:17
12

Unfortunately, the Array type in VB6 didn't have all that many razzmatazz features. You are pretty much going to have to just iterate through the arrays and insert them manually into the third

Assuming both arrays are of the same length

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

Updated: Fixed the code. Sorry about the previous buggy version. Took me a few minutes to get access to a VB6 compiler to check it.

JohnFx
  • 34,542
  • 18
  • 104
  • 162
  • 1
    Summing the UBounds gives a size off-by-one, and the write index into the output array should be stepped separately from read index into the source arrays. Let this be a lesson in how annoying VBA arrays can be to work with! – jtolle Oct 19 '09 at 14:50
  • 2
    Just to expound on annoying VBA arrays...especially when combining Excel and VBA, the main thing you need to know is that arrays can have arbitrary lower bounds. If you don't specifiy one, then the LB is set by the Option Base setting. But arrays created with Array() and ParamArrays always have a LB of 0. Arrays passed from Excel always have a LB of 1. It's no big deal when iterating a single array - use For Each or LBound and UBound - but working with two arrays at once suddenly means you have to think about details like bounds and indices... – jtolle Oct 19 '09 at 15:11
  • I'm not recommending it, but default LB can be set to 1 if you use `Option Base 1` – Mike Woodhouse Oct 19 '09 at 16:12
  • I really hate "Option Base". It's like a mysterious action at a distance, module-by-module, just to avoid typing in a lower bound. I know it pre-dates VB/VBA, though, and was relevant once upon a time... – jtolle Oct 19 '09 at 16:40
  • I was wrong about the LB of an array created with Array() in my comment above. It *is* affected by the Option Base setting. ParamArrays are not, though. – jtolle Oct 21 '09 at 17:21
4

This function will do as JohnFx suggested and allow for varied lengths on the arrays

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
Buggabill
  • 13,726
  • 4
  • 42
  • 47
  • 1
    Note to anyone finding this... it actually merges the arrays... doesn't keep the order of the elements if that's important to you. – seadoggie01 Oct 16 '19 at 15:33
4

I tried the code provided above, but it gave an error 9 for me. I made this code, and it worked fine for my purposes. I hope others find it useful as well.

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
Johannes
  • 41
  • 1
2

It work if Lbound is different than 0 or 1. You Redim once at start

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
GeoStoneMarten
  • 533
  • 1
  • 7
  • 19
2

I would like to adapt the great idea from user3286479 to work with arrays that came from single column ranges:

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), ","), ",")
1

My preferred way is a bit long, but has some advantages over the other answers:

  • It can combine an indefinite number of arrays at once
  • It can combine arrays with non-arrays (objects, strings, integers, etc.)
  • It accounts for the possibility that one or more of the arrays may contain objects
  • It allows the user to choose the base of the new array (0, 1, etc.)

Here it is:

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
Daniel McCracken
  • 484
  • 1
  • 5
  • 11
1

Unfortunately there is no way to append / merge / insert / delete elements in arrays using VBA without doing it element by element, different from many modern languages, like Java or Javascript.

It's possible using split and join to do it, like a previous answer has showed, but it is a slow method and it is not generic.

For my personal use, I've implemented a splice functions for 1D arrays, similar to Javascript or Java. splice get an array and optionally delete some elements from a given position and also optionally insert an array in that position

'*************************************************************
'*                      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

For testing

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

Results in

100,201,202,103,104,105,106,107,108,109
Paulo Buchsbaum
  • 2,471
  • 26
  • 29
1

Following the @johannes solution, but merging without loosing data (it was missing first elements):

    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
Felipe Maion
  • 336
  • 1
  • 12
1

To join Array1 and Array2, create a new array say 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
Naresh
  • 2,984
  • 2
  • 9
  • 15
  • Suitable for 2 one dimensional arrays of same or different sizes. Results could be checked with `Debug.Print Join(Array1, ",") Debug.Print Join(Array2, ",") Debug.Print Join(JointArray, ",")` – Naresh Sep 03 '21 at 12:47
0

Here's a version that uses a collection object to combine two 1-d arrays and pass them to a 3rd array. Doesn't work for multi-dimensional arrays.

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
0
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
Dmytro Dadyka
  • 2,208
  • 5
  • 18
  • 31
0

Or even a way that either variable can be uninitialised or an empty array or an array of objects (eg Dictionary objects). Only handles one dimension at a time, though. Also, it APPENDS arr2 to arr1 rather than merges.

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
Murrah
  • 1,508
  • 1
  • 13
  • 26
0

I really appreciated Buggabill's and Daniel McCracken's responses. I needed a function to combine multidimensional arrays, but I'm sure I'll use Daniel's in the future. I made a couple mods to Buggabill's to 1) accommodate multidimensional arrays with a mix of variables and objects, and 2) merge the two arrays sequentially rather than meshed together (since the two arrays are combined in each step of the For loop). See the Was/Now examples below for an illustration.

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

Hope this helps some of you.

Jedi-X
  • 21
  • 6
0
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
T.M.
  • 9,436
  • 3
  • 33
  • 57
Mirec
  • 1
0

Extension on Split approach using ArrayToText() function (MS365)

If you dispose of MS/Excel 365 you may simplify joins & splits ( see @user3286479 's most upvoted post ) by passing a so called jagged array (a.k.a. as array of arrays) as main argument. This jagged array may comprise two or even more arrays, not only arr1 and arr2.

As a further benefit I included the option to decide whether the array returns the merged array elements consecutively (default value additive=True) or not (i.e. intertwined with explicit argument 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

Example call

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

Results in VB Editor's immediate window

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

Caveat

A possible disadvantage of the approach above is that all elements would be returned as strings, thus including all numeric values as well. To avoid this situation, you might use the following function alternatively using FilterXML() (available btw since vers. 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
T.M.
  • 9,436
  • 3
  • 33
  • 57
0

Here's my version.

  • Any length
  • Any datatype
  • Shallow copy, but works for Array() elements
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
Steve
  • 117
  • 1
  • 9