synkronisering to lister med VBA

stemmer
3

Hva er den beste måten å synkronisere to lister som hver kan inneholde elementer som ikke er i den andre? Som vist listene ikke er sortert - selv om nødvendig sortere dem først ikke ville være et problem.

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

Ved hjelp av disse listene, jeg leter etter en løsning som vil skrive ut til et regneark i to kolonner:

a
b  b
c  c
   d
e  e
Publisert på 22/10/2008 klokken 16:23
kilden bruker
På andre språk...                            


3 svar

stemmer
3

Her er noen notater om hvordan du bruker en frakoblet post.

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
Svarte 22/10/2008 kl. 17:51
kilden bruker

stemmer
3

Her er et annet alternativ, denne gangen ved hjelp Dictionaries (legg en referanse til Microsoft Scripting Runtime, som også har flere andre enormt nyttige gjenstander - ikke begynne å VBA koding uten!)

Som skrevet, er resultatet ikke sorteres - det kan være litt av en showstopper. Uansett, det er et par fine små triks her:

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
Svarte 22/10/2008 kl. 18:41
kilden bruker

stemmer
0

Et annet alternativ er samlinger. Dette betyr ikke sortere utgangs alfabetisk, men du kan sortere listene først hvis du må. Merk dette vil også gi deg en unik liste, stripping ut duplikater. Koden foruts listene er i streng arrays L1 og 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
Svarte 22/10/2008 kl. 21:40
kilden bruker

Cookies help us deliver our services. By using our services, you agree to our use of cookies. Learn more