Question

同步两个列表的最佳方法是什么，每个列表可能包含不在另一个列表中的项目？如图所示，列表没有排序 - 尽管如果必要，首先排序它们不会是一个问题。

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

使用上面的列表，我正在寻找一个解决方案，该解决方案将在两列中写出电子表格：

a
b  b
c  c
   d
e  e

Answer 1

以下是使用断开连接的记录集的一些注意事项。

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

这是另一个选项，这次使用Dictionaries（添加对Microsoft Scripting Runtime的引用，其中还有其他一些非常有用的对象 - 没有它就不能启动VBA编码！）

正如所写，输出没有排序 - 这可能是一个showstopper。无论如何，这里有一些不错的小技巧：

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

另一个选项是收藏。这不会按字母顺序对输出进行排序，但如果需要，可以先对列表进行排序。请注意，这也会为您提供一个唯一的列表，删除重复项。该代码假定您的列表位于字符串数组L1和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

使用VBA同步两个列表

3 个答案: