[英]How do I Merge two Arrays in 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)
试试这个:
arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",")
不幸的是,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 编译器来检查它。
此函数将按照 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
我尝试了上面提供的代码,但它给了我一个错误 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
如果 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
我的首选方式有点长,但与其他答案相比有一些优势:
这里是:
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
不幸的是,没有办法使用 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
要加入 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
我想采用 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), ","), ",")
这是一个使用集合对象组合两个一维数组并将它们传递给第三个数组的版本。 不适用于多维数组。
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
遵循@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
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
或者甚至可以是未初始化变量或空数组或对象数组(例如字典对象)的方式。 但是,一次只处理一个维度。 此外,它将 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
我非常感谢布格比尔和丹尼尔麦克拉肯的回应。 我需要一个函数来组合多维数组,但我确信我将来会使用 Daniel 的。 我对 Buggabilll 做了一些修改,以 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
希望这对你们中的一些人有所帮助。
子合并数组测试()
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
结束子
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
使用ArrayToText()
函数扩展Split
方法(MS365)
如果您处理了 MS/Excel 365,您可以通过传递一个所谓的锯齿状数组(也称为数组数组)作为主要参数来简化连接和拆分(请参阅@user3286479 最受好评的帖子) 。 作为进一步的好处,我包括了决定数组是否连续返回合并数组元素的选项(默认值additive=True
)或不(即与显式参数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
示例调用
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()
(顺便说FilterXML()
自 2013 年以来可用FilterXML()
交替使用以下函数:
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.