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

Which version excel do you use. In Excel 365 there is a built in UNIQUE-function — Ike
– Ike, Commented Aug 1, 2022 at 19:19
Yes i am using Excel 365 but After using this function i have to get unique values for each of column. using VBA — HSHO
– HSHO, Commented Aug 1, 2022 at 19:20
This may be of interest: stackoverflow.com/questions/62204826/… — urdearboy
– urdearboy, Commented Aug 1, 2022 at 19:30
Or use =UNIQUE(A:A) as Formula in J2 - it will spill down automatically. — Ike
– Ike, Commented Aug 1, 2022 at 19:49

urdearboy · Accepted Answer · 2022-08-02 15:32:56Z

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

I actually was looking for this solution instead of repeating Unique function for each column Separalty. Thank you very much.
@urdearboy: I added the UNIQUE-solution as an alternative solution :-)

Ike · Accepted Answer · 2022-08-02 06:38:35Z

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) ...

Collectives™ on Stack Overflow

Getting unique values for multiple column separatly

2 Answers 2

2 Comments

1 Comment

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

2 Comments

1 Comment

Linked

Related