Как объединить два массива в VBA?

Учитывая

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

К сожалению, тип массива в VB6 не обладал множеством функций 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, чтобы проверить его.

Ответ 2

Попробуйте следующее:

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

Ответ 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

Ответ 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

Ответ 5

Работает, если Lbound отличается от 0 или 1. Вы переиздаете один раз при запуске

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

Ответ 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

Ответ 7

К сожалению, нет способа добавить/объединить/вставить/удалить элементы в массивах, используя VBA, не делая это элемент за элементом, в отличие от многих современных языков, таких как Java или Javascript.

Для этого можно использовать 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

Ответ 8

Здесь версия, которая использует объект коллекции, чтобы объединить два 1-го массива и передать их в 3-й массив. Не работает для многомерных массивов.

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

Ответ 9

После решения @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

Ответ 10

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