Comment fusionner deux tableaux dans VBA?
Donné
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
arr1 = Array("A", 1, "B", 2)
arr2 = Array("C", 3, "D", 4)
Quel type d'opérations puis-je effectuer sur arr1 et arr2 et stocker le résultat dans arr3 tel que:
arr3 = ("A", "C", 1, 3, "B", "D", 2, 4)
Malheureusement, le type Array dans VB6 n’avait pas autant de fonctionnalités razzmatazz. Vous allez à peu près devoir simplement parcourir les tableaux et les insérer manuellement dans le troisième
En supposant que les deux tableaux ont la même longueur
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
Mis à jour: Correction du code. Désolé pour la version précédente buggy. Il m'a fallu quelques minutes pour avoir accès à un compilateur VB6 pour le vérifier.
Essaye ça:
arr3 = Split(Join(arr1, ",") & "," & Join(arr2, ","), ",")
Cette fonction fonctionnera comme suggéré par JohnFx et autorisera des longueurs variées sur les tableaux.
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
Cela fonctionne si Lbound est différent de 0 ou 1. Vous redimez une fois au début
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
J'ai essayé le code fourni ci-dessus, mais cela m'a donné une erreur 9. J'ai créé ce code, qui a bien fonctionné. J'espère que d'autres le trouveront utile aussi.
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
Ma méthode préférée est un peu longue, mais présente certains avantages par rapport aux autres réponses:
- Il peut combiner un nombre indéfini de tableaux à la fois
- Il peut combiner des tableaux avec des non-tableaux (objets, chaînes, entiers, etc.)
- Il rend compte de la possibilité qu’un ou plusieurs tableaux contiennent des objets
- Il permet à l'utilisateur de choisir la base du nouveau tableau (0, 1, etc.)
C'est ici:
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
Malheureusement, il n'y a aucun moyen d'ajouter/fusionner/insérer/supprimer des éléments dans des tableaux utilisant VBA sans le faire élément par élément, différent de nombreux langages modernes, comme Java ou Javascript.
Il est possible d'utiliser split et join pour le faire, comme l'a montré une réponse précédente, mais c'est une méthode lente et elle n'est pas générique.
Pour mon usage personnel, j'ai implémenté une fonction splice pour les tableaux 1D, similaire à Javascript ou Java. splice obtenir un tableau et éventuellement supprimer certains éléments d'une position donnée et éventuellement insérer un tableau dans cette 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
Pour tester
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
Résulte en
100,201,202,103,104,105,106,107,108,109
Voici une version qui utilise un objet de collection pour combiner deux tableaux un-d et les passer À un troisième tableau. Ne fonctionne pas pour les tableaux multidimensionnels.
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