Thread: Compare columns in excel

Hello maximpinto,

The attached workbook has a button on Sheet1 to run the macro. The macro will compare the columns "A" and "C". Only values unique to each are list in column "B". The starting row is row 3. If you have a large data set, this is the fastest method. You won't lose time copying formulas and the execution is very fast.

Code:

'Written: March 18, 2010
'Author:  Leith Ross

Sub ListUniques()

  Dim Cell As Range
  Dim DSO As Object
  Dim Key As Variant
  Dim Keys As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngA As Range
  Dim RngB As Range
  Dim RngC As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet1")
    
    Set Rng = Wks.Range("A3"): GoSub SizeRange: Set RngA = Rng
    Set Rng = Wks.Range("B3"): GoSub SizeRange: Set RngB = Rng
    Set Rng = Wks.Range("C3"): GoSub SizeRange: Set RngC = Rng
    
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
      
      Set Rng = Union(RngA, RngC)
      
      For Each Cell In Rng
        If Not IsEmpty(Cell.Value) Then
          Key = Trim(Cell.Value)
          If Not DSO.Exists(Key) Then
            DSO.Add Key, 1
          Else
            DSO.Remove Key
          End If
        End If
      Next Cell
      
   RngB.ClearContents
   RngB.Resize(DSO.Count, 1) = WorksheetFunction.Transpose(DSO.Keys)
   
   Set DSO = Nothing
   Exit Sub
   
SizeRange:
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
    Return
    
End Sub

Hello Max,

I modified the macro to list both uniques and duplicates. Here is the new macro code. This has been added to the attached workbook.

Code:

'Written: March 19, 2010
'Author:  Leith Ross
'Summary: Compare columns "A" and "C". List uniques in column "B" and duplicates in column "D"

Sub ListUniques()

  Dim Cell As Range
  Dim Dupes() As Variant
  Dim Key As Variant
  Dim Keys As Variant
  Dim LastRow As Long
  Dim N As Long
  Dim Rng As Range
  Dim RngA As Range
  Dim RngB As Range
  Dim RngC As Range
  Dim RngD As Range
  Dim RngEnd As Range
  Dim Uniques As Object
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet1")
    
    Set Rng = Wks.Range("A3"): GoSub SizeRange: Set RngA = Rng
    Set Rng = Wks.Range("B3"): GoSub SizeRange: Set RngB = Rng
    Set Rng = Wks.Range("C3"): GoSub SizeRange: Set RngC = Rng
    Set Rng = Wks.Range("D3"): GoSub SizeRange: Set RngD = Rng
    
      Set Uniques = CreateObject("Scripting.Dictionary")
      Uniques.CompareMode = vbTextCompare
      
      Set Rng = Union(RngA, RngC)
      
      For Each Cell In Rng
        If Not IsEmpty(Cell.Value) Then
          Key = Trim(Cell.Value)
          If Not Uniques.Exists(Key) Then
            Uniques.Add Key, 1
          Else
            Uniques.Remove Key
          End If
        End If
      Next Cell
      
   RngB.ClearContents
   RngB.Resize(Uniques.Count, 1) = WorksheetFunction.Transpose(Uniques.Keys)
   
      For Each Cell In Rng
        If Not IsEmpty(Cell.Value) Then
          Key = Trim(Cell.Value)
          If Not Uniques.Exists(Key) Then
            N = N + 1
            ReDim Preserve Dupes(1 To 1, 1 To N)
            Dupes(1, N) = Key
          End If
        End If
      Next Cell
      
   RngD.ClearContents
   RngD.Resize(N, 1) = WorksheetFunction.Transpose(Dupes)
   
   Set Uniques = Nothing
   Exit Sub
   
SizeRange:
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
    Return
    
End Sub