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)
What kind of operations can I do on arr1 and arr2 and store result in arr3 such that:
arr3 = ("A", "C", 1, 3, "B", "D", 2, 4)
试试这个:
arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",")
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.
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
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
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
My preferred way is a bit long, but has some advantages over the other answers:
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
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
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
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), ","), ",")
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
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
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
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
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.
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
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 (aka as array of arrays) as main argument. 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 (ie intertwined with explicit argument additive=False
).
Function MergeArr(jagged As Variant, _
Optional ByVal additive As Boolean = True)
'Note: returns only string elements
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.