Getting unique values for multiple column separatly

Question

What is worng with my function its loading the two different column A and B and pasting the unique values of column A into Column M and N .

I want to repeat this function for the 7 columns.

I would appreciate your help in this regards.

Sub GetUniques()

Dim d As Object, c As Variant, i As Long, lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long
Set d = CreateObject("Scripting.Dictionary")

lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)

lr2 = Cells(Rows.Count, 2).End(xlUp).Row
e = Range("B2:B" & lr2)

For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i

For i = 1 To UBound(e, 1)
  d(e(i, 1)) = 1
Next i

Range("M2").Resize(d.Count) = Application.Transpose(d.keys)
Range("N2").Resize(d.Count) = Application.Transpose(d.keys)
End Sub

Answer 1

It looks like your plan is to have a lr variable for each column as well as loops and transpose statements. You can avoid this by nesting your code in a column loop.

The current Column range is hard coded here ( A to E ) but this can be updated to be dynamic as needed. The output is also hard coded to be dropped 9 columns to the right of the input column. This aligns with A to J , B to K , etc.

---

Sub GetUniques()

Dim c As Variant, i As Long, lr As Long, col As Long
Dim d As Object

For col = 1 To 5     'Column A to E

    Set d = CreateObject("Scripting.Dictionary")
    
        lr = Cells(Rows.Count, col).End(xlUp).Row
        c = Range(Cells(2, col), Cells(lr, col))
    
        For i = 1 To UBound(c, 1)
            d(c(i, 1)) = 1
        Next i
    
        Cells(2, col + 9).Resize(d.Count) = Application.Transpose(d.keys)
    
    Set d = Nothing

Next col


End Sub

---

Answer 2

I am adding the UNIQUE - solution - for completeness:

You can either use a manual formula in J2 : =UNIQUE(A:E,TRUE) - the second parameter tells UNIQUE to put out unique values per column --> it will spill from J to N .

You can use this formula in a VBA-routine as well:

Public Sub writeUniqueValues(rgSource As Range, rgTargetTopLeftCell As Range)

With rgTargetTopLeftCell
    .Formula2 = "=UNIQUE(" & rgSource.Address & ",TRUE)"
    With .SpillingToRange
       .Value = .Value 'this will replace the formula by values
    End With
End With

End Sub

You can then use this sub like this:

Public Sub test_writeUniqueValues()

With ActiveSheet 'be careful: you should always use explicit referencing
    Dim lr As Long
    lr = .Cells(Rows.Count, 1).End(xlUp).Row

    writeUniqueValues .Range("A2:E" & lr), .Range("J2")
End With

End Sub

It would be interesting to compare performance of both solutions (using the formula vs. using a dictionary)...