syncing two lists with VBA


What is the best way to sync up two lists each of which may contain items not in the other? As shown the lists are not sorted - although if necessary sorting them first would not be an issue.

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

Using the lists above, I'm looking for a solution that will write out to a spreadsheet in two columns:

b  b
c  c
e  e


Another option is Collections. This doesn't sort the output alphabetically, but you can sort the lists first if you need to. Note this will also give you a unique list,stripping out duplicates. The code assumes your lists are in string arrays L1 and 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
By : dbb

Here's another option, this time using Dictionaries (add a reference to Microsoft Scripting Runtime, which also has several other hugely useful objects - don't start VBA coding without it!)

As written, the output isn't sorted - that could be a bit of a showstopper. Anyway, there are a couple of nice little tricks here:

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)

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

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

End Function

Here are some notes on using a disconnected recordset.

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

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

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

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


rs.Sort = "Srt"

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


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

    intRow = intRow + 1
Loop Until rs.EOF = True
By : Fionnuala

This video can help you solving your question :)
By: admin