CODEWITHSUNDEEP
excelvba
HSHO
HSHO

Reputation: 525

Getting unique values for multiple column separatly

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

Upvotes: 0

Views: 120

Answers (2)

urdearboy
urdearboy

Reputation: 14580

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

Upvotes: 1

Ike
Ike

Reputation: 13014

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

Upvotes: 1

Related Questions