synchronisation de deux listes avec VBA

Question

Quelle est la meilleure façon de synchroniser deux listes dont chacune peut contenir des éléments qui ne sont pas dans l'autre? Comme indiqué, les listes ne sont pas triées, mais si nécessaire, les trier d'abord ne poserait aucun problème.

List 1 = a,b,c,e 
List 2 = b,e,c,d 

En utilisant les listes ci-dessus, je suis à la recherche d'une solution qui va écrire sur une feuille de calcul en deux colonnes:

a 
b b 
c c 
    d 
e e 

Answer 1

Voici quelques notes sur l'utilisation d'un jeu d'enregistrements déconnecté.

Const adVarChar = 200 'the SQL datatype is varchar 

'Create arrays fron the lists 
asL1 = Split("a,b,c,", ",") 
asL2 = Split("b,e,c,d", ",") 

'Create a disconnected recordset 
Set rs = CreateObject("ADODB.RECORDSET") 
rs.Fields.append "Srt", adVarChar, 25 
rs.Fields.append "L1", adVarChar, 25 
rs.Fields.append "L2", adVarChar, 25 

rs.CursorType = adOpenStatic 
rs.Open 

'Add list 1 to the recordset 
For i = 0 To UBound(asL1) 
    rs.AddNew Array("Srt", "L1"), Array(asL1(i), asL1(i)) 
    rs.Update 
Next 

'Add list 2 
For i = 0 To UBound(asL2) 
    rs.MoveFirst 
    rs.Find "L1='" & asL2(i) & "'" 

    If rs.EOF Then 
     rs.AddNew Array("Srt", "L2"), Array(asL2(i), asL2(i)) 
    Else 
     rs.Fields("L2") = asL2(i) 
    End If 

    rs.Update 
Next 

rs.Sort = "Srt" 

'Add the data to the active sheet 
Set wks = Application.ActiveWorkbook.ActiveSheet 

rs.MoveFirst 

intRow = 1 
Do 
    For intField = 1 To rs.Fields.Count - 1 
     wks.Cells(intRow, intField + 1) = rs.Fields(intField).Value 
    Next intField 

    rs.MoveNext 
    intRow = intRow + 1 
Loop Until rs.EOF = True 

Answer 2

est ici une autre option, cette fois en utilisant dictionnaires (ajoutez une référence à Microsoft Scripting Runtime, qui a aussi plusieurs autres objets extrêmement utiles - ne commencez pas à codage VBA sans)

Comme écrit, la sortie n'est pas triée - cela pourrait être un peu un showstopper. Quoi qu'il en soit, il y a quelques petites astuces ici:

Option Explicit 

Public Sub OutputLists() 

Dim list1, list2 
Dim dict1 As Dictionary, dict2 As Dictionary 
Dim ky 
Dim cel As Range 

    Set dict1 = DictionaryFromArray(Array("a", "b", "c", "e")) 
    Set dict2 = DictionaryFromArray(Array("b", "e", "c", "d")) 

    Set cel = ActiveSheet.Range("A1") 

    For Each ky In dict1.Keys 
     PutRow cel, ky, True, dict2.Exists(ky) 
     If dict2.Exists(ky) Then 
      dict2.Remove ky 
     End If 
     Set cel = cel.Offset(1, 0) 
    Next 

    For Each ky In dict2 
     PutRow cel, ky, False, True 
     Set cel = cel.Offset(1, 0) 
    Next 

End Sub 

Private Sub PutRow(cel As Range, val As Variant, in1 As Boolean, in2 As Boolean) 

Dim arr(1 To 2) 

    If in1 Then arr(1) = val 
    If in2 Then arr(2) = val 
    cel.Resize(1, 2) = arr 

End Sub 

Private Function DictionaryFromArray(arr) As Dictionary 

Dim val 

    Set DictionaryFromArray = New Dictionary 
    For Each val In arr 
     DictionaryFromArray.Add val, Nothing 
    Next 

End Function 

Answer 3

Une autre option est Collections. Cela ne triera pas la sortie par ordre alphabétique, mais vous pouvez trier les listes en premier si nécessaire. Notez que cela vous donnera également une liste unique, en supprimant les doublons. Le code suppose que vos listes sont dans les tableaux de chaînes L1 et L2.

Dim C As New Collection,i As Long, j As Long 
ReDim LL(UBound(L1) + UBound(L2), 2) As String 'output array 

For i = 1 To UBound(L1) 
    On Error Resume Next 'try adding to collection 
    C.Add C.Count + 1, L1(i) 'store sequence number,ie 1,2,3,4,... 
    On Error GoTo 0 
    j = C(L1(i)) 'look up sequence number 
    LL(j, 1) = L1(i) 
Next i 

For i = 1 To UBound(L2) 'same for L2 
    On Error Resume Next 
    C.Add C.Count + 1, L2(i) 
    On Error GoTo 0 
    j = C(L2(i)) 
    LL(j, 2) = L2(i) 
Next i 

'Result is in LL, number of rows is C.Count 
Range("Results").Resize(UBound(LL, 1), 2) = LL