Ikke dubletter - VBA

skal du sammenligne to kolonner eller skal du bare se for hver kolonne hvilke der er unikke?

Skal sammenligne 2 kolonner - det er kun den ene kolonne som (måske) har unikke værdier

prøv lige at teste denne kode, jeg har lavet specielt til dette formål.
det kan være at den kræver en lille ændring, men den laver et nyt ark hvor den indsætter resultaterne.

du skal bare køre CompareMyListsRange


Option Explicit

Sub CompareMyListsRange()
  Dim Rng1 As Range
  Dim Rng2 As Range
  Dim myArray As Variant
  Dim wsNew As Worksheet
  Dim rStart1 As Range
  Dim rStart2 As Range
  myArray = Array("Er i 1 og ikke i 2", "Er i 2 og ikke i 1", "I begge lister", "Dubletter i liste 1", "Dubletter i liste 2")
  Set rStart1 = Application.InputBox("Udpeg 1. celle i liste 1", , , , , , , 8)
  Set rStart2 = Application.InputBox("Udpeg 1. celle i liste 2", , , , , , , 8)


  Set wsNew = Worksheets.Add
  'wsNew.Name = "Sammenlign"
  wsNew.Range("A1:E1") = myArray

  'set list1 and list2 ranges
  Set Rng1 = Range(rStart1.Offset(1, 0), rStart1.Cells(65536, 1).End(xlUp))
  Set Rng2 = Range(rStart2.Offset(1, 0), rStart2.Cells(65536, 1).End(xlUp))

  'find all values in list1, that is not present in list2
  Call DoCompareLists1(Rng1, Rng2, wsNew.Range("a2"), False)
  'find all values in list2, that is not present in list1
  Call DoCompareLists1(Rng2, Rng1, wsNew.Range("b2"), False)
  'find all values that is present in both list1 and list2
  Call DoCompareLists1(Rng1, Rng2, wsNew.Range("c2"), True)
  'find all duplicates in List1
  Call ListDuplicates(Rng1, wsNew.Range("d2"))
  'find all duplicates in List1
  Call ListDuplicates(Rng2, wsNew.Range("e2"))
  wsNew.Range("A:E").Columns.AutoFit
End Sub


Private Sub DoCompareLists1(rList1 As Range, rList2 As Range, rOutput As Range, bSingleOrBoth As Boolean)
'Range version.
'If bSingleOrBoth = False then this macro will find every value in
'rList1 that is NOT present in rList2
'If bSingleOrBoth = True then it will find all values in rList1
'which IS ALSO present in rlist2 (present in both lists)
  Dim dicUniqList As New Dictionary
  Dim strTemp As String
  Dim lCount As Long
  Dim c As Range
  'prepare a List of results
  ReDim ResultList(1 To rList1.Rows.Count)
  'prevent errormsg's when trying to add duplicate key
  On Error Resume Next
  'read list2 into a dictionary, converted to strings
  For Each c In rList2
      strTemp = CStr(c.Value)
      dicUniqList.Add Key:=strTemp, Item:=strTemp
  Next
  'set errorhandling on again
  On Error GoTo 0
  'check every cell in list1 against the dictionary
  For Each c In rList1
      'convert cellvalue to string
      strTemp = CStr(c)
      'check if the cellvalue exists in the dictionary and
      'depending on bSingleOrBoth put the value into the resultlist
      If dicUniqList.Exists(strTemp) = bSingleOrBoth Then
        lCount = lCount + 1
        ResultList(lCount) = strTemp
      End If
      On Error Resume Next
      dicUniqList.Add (strTemp), strTemp
      On Error GoTo 0
  Next
  'reduce arraysize to correct dimensions
  ReDim Preserve ResultList(1 To lCount)
  'resize the outputarea, transpose the resultlist and write it back to the worksheet
  rOutput.Resize(lCount) = Application.Transpose(ResultList)
  'clean up
  Set dicUniqList = Nothing
End Sub

Sub ListDuplicates(rList, rOutput)
  Dim dicUniqs As New Dictionary
  Dim Cell As Range
  Dim x As Long
  ReDim ResultList(1 To rList.Rows.Count)
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  On Error Resume Next
  For Each Cell In rList
      dicUniqs.Add Cell.Value, CStr(Cell.Value)
      If Err.Number <> 0 Then
        x = x + 1
        ResultList(x) = Cell.Value
      End If
      Err.Clear
  Next Cell
  ReDim Preserve ResultList(1 To x)
  rOutput.Resize(x) = Application.Transpose(ResultList)
  Set dicUniqs = Nothing
  Erase ResultList
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

PS. Vigtigt...
Når du har indsat koden skal du under Tools / references sætte reference til
Microsoft Scripting Runtime

Den virker rimelig ambitiøs!

Men jeg får en fejl i "ReDim Preserve ResultList(1 To lCount)" i Private Sub DoCompareLists1

"Subscript out of range"

Desuden er det nok at liste de unikke værdier!

ok, her er en anden version

Sub GetUniqs()
Dim Rng1 As Range
Dim Rng2 As Range
Dim myHeader As Variant
Dim wsNew As Worksheet
Dim rstart1 As Range
Dim rStart2 As Range

  myHeader = "Alle unikke"
  Set rstart1 = Application.InputBox("Udpeg 1. celle i liste 1 (overskrift)", , , , , , , 8)
  Set rStart2 = Application.InputBox("Udpeg 1. celle i liste 2 (overskrift)", , , , , , , 8)
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
 
  Set wsNew = ActiveWorkbook.Worksheets.Add
  wsNew.Range("A1") = myHeader

  'set list1 and list2 ranges
  Set Rng1 = Range(rstart1.Offset(1, 0), rstart1.Cells(65536, 1).End(xlUp))
  Set Rng2 = Range(rStart2.Offset(1, 0), rStart2.Cells(65536, 1).End(xlUp))

  Call ListAllUniqs(Rng1, Rng2, wsNew.Range("A2"))
  'autofit resultcolumn
  wsNew.Range("A:A").Columns.AutoFit
 
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

End Sub

Sub ListAllUniqs(rList1 As Range, rList2 As Range, rOutput As Range)
Dim dicUniqs As New Collection
Dim Cell As Range
Dim x As Long
Dim i
  On Error Resume Next
  For Each Cell In rList1
      dicUniqs.Add Cell.Value, CStr(Cell.Value)
      Err.Clear
  Next Cell
 
  For Each Cell In rList2
      dicUniqs.Add Cell.Value, CStr(Cell.Value)
      Err.Clear
  Next Cell
  ReDim resultlist(1 To dicUniqs.Count)
  x = 1
  For Each i In dicUniqs
      resultlist(x) = i
      x = x + 1
  Next
 
  rOutput.Resize(x - 1) = Application.Transpose(resultlist)
  Set dicUniqs = Nothing
  Erase resultlist
 
End Sub

Har det noget at sige at der ikke er tale om TAL-værdier? Jeg får nemlig godt nok en liste, men den indeholder samtlige værdier - og ikke kun unikke?

Nå lukketid! Løsning fandt jeg ikke..