udbygning af sammenlignings makro

Denne makro (lavet af bak) laver to lister med de celler der _IKKE_ er ens - er der en der kan hjælpe mig med at tilføje en liste med alle dem som er ens ?

---


Option Explicit
Option Base 1
Sub Init_Compare()
  '''Dim af variable
  Dim TB1 As Range, TB2 As Range, TB3 As Range
  Dim Temp As Range
  Dim IndexCol1 As Long, IndexCol2 As Long
  Dim StartTid As Double
  Dim ReturnArray As Variant
 
  With Application
      Set TB1 = .InputBox("Marker overskrift af område 1", Type:=8)
      TB1.Parent.Activate
      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol1 = Temp.Column - TB1.Column + 1
      Set TB2 = .InputBox("Marker overskrift af område 2", Type:=8)
      TB2.Parent.Activate
      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol2 = Temp.Column - TB2.Column + 1
      Set TB3 = .InputBox("Marker 1. celle af resultatområde", Type:=8)
      TB3.Parent.Activate
  End With
 
  StartTid = Timer
  DoCompare2Lists TB1, TB2, IndexCol1, IndexCol2, ReturnArray
  TB3.Range(TB3.Cells(1, 1), TB3.Cells(UBound(ReturnArray, 1), UBound(ReturnArray, 2))) = ReturnArray
 
  DoCompare2Lists TB2, TB1, IndexCol2, IndexCol1, ReturnArray
  TB3.Range(TB3.Cells(1, TB2.Columns.Count + 1), TB3.Cells(UBound(ReturnArray, 1), UBound(ReturnArray, 2) + TB2.Columns.Count)) = ReturnArray
 
  MsgBox "Færdig  tid : " & Timer - StartTid
  Set ReturnArray = Nothing
End Sub

Sub DoCompare2Lists(WS1 As Range, WS2 As Range, SearchCol1 As Long, SearchCol2 As Long, aForskel As Variant)
  Dim xCol As Scripting.Dictionary
  Dim Fundet As Boolean, Last1 As Long, Last2 As Long
  Dim Cols2 As Long
  Dim i As Long, z As Long, x As Long
 
  Set xCol = New Scripting.Dictionary
  Cols2 = WS2.Columns.Count
  Last1 = WS1.Cells(65536, SearchCol1).End(xlUp).Row
  Last2 = WS2.Cells(65536, SearchCol2).End(xlUp).Row
  ReDim aForskel(Last2, Cols2)
  z = 0
 
  On Error Resume Next
  With WS1
      For i = 1 To Last1
        xCol.Add Item:=CStr(.Cells(i, SearchCol1)), Key:=CStr(.Cells(i, SearchCol1))
      Next
  End With
  With WS2
      For i = 1 To Last2
        Fundet = xCol.Exists(CStr(.Cells(i, SearchCol2)))
        If Not Fundet = True Then
            z = z + 1
            For x = 1 To Cols2
              aForskel(z, x) = .Cells(i, x)
            Next
        End If
        Fundet = True
      Next
  End With
  Set xCol = Nothing
End Sub