• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

code to get the unique values/count in any column

M

macro_learning

New Member
Hi,

I have found the below code to get the unique values/count in any column,

Sub UniqueList()

Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")

Sheet1.Activate
lastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row

On Error Resume Next
For i = 1 To lastRow
If Len(Cells(i, "A")) <> 0 Then
dictionary.Add Cells(i, "A").Value, 1
End If
Next

Sheets(1).Range("C1") = dictionary.Count
Sheets(1).Range("B1").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)

Application.ScreenUpdating = True

MsgBox dictionary.Count & " unique cell(s) were found and copied."

End Sub

it is executing below code properly:
MsgBox dictionary.Count & " unique cell(s) were found and copied."

However below code is not working , I want this to paste unique count and values in column c and b respectively,

Sheets(1).Range("C1") = dictionary.Count
Sheets(1).Range("B1").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)

And if possible can anyone please explain me how this vba UniqueList() is actually working and giving the desired output.

Regards,
macro_learning
 
Try this
Code: 
Sub UniqueList()
'The Code Extracts The Unique Values From Column A And Put Unique Values In Column B
'-----------------------------------------------------------------------------------
    'Declare Variables
    Dim I As Long
    Dim lastRow As Long
    Dim dictionary As Object

    'Set The Variable To Hold Dictionary Object (Used To Hold Unique Values Only)
    Set dictionary = CreateObject("scripting.dictionary")

    'Determine The Last Row In Column A
    lastRow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

    'Disable Screen Updating
    Application.ScreenUpdating = False

        'If The Value That Will Be Added To The Dictionary Is Existing Then It
        'Produces An Error And This Line To Avoid The Error Message
        On Error Resume Next
   
        'Loop Through Rows 1 To Last Row In Column A
        For I = 1 To lastRow
   
            'Check If The Cell Is Not Empty
            If Len(Cells(I, "A")) <> 0 Then
   
                'If The Cell Is Not Empty Then Add The Value Of The Cell To The Dictionary
                dictionary.Add Cells(I, "A").Value, 1
            End If
        Next I
   
        'Put The Number Of The Dictionary Keys In C1
        Sheets(1).Range("C1") = dictionary.Count
   
        'Put The Dictionary Keys In B1. Transpose Is Used To Put Results In Vertical Array
        Sheets(1).Range("B1").Resize(dictionary.Count).Value = Application.Transpose(dictionary.keys)

    'Enable Screen Updating
    Application.ScreenUpdating = True

    'End The Code With Displaying The Dictionary Keys (Unique Items Added)
    MsgBox dictionary.Count & " Unique Cell(s) Were Found And Copied."
End Sub
 
macro_learning said:
However below code is not working , I want this to paste unique count and values in column c and b respectively,

Sheets(1).Range("C1") = dictionary.Count
Sheets(1).Range("B1").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Click to expand...
Perhaps
Code: 
Sub UniqueList()

    Application.ScreenUpdating = False
    Dim lastRow As Long
    Dim i As Long
    Dim Dictionary As Object, w
    Set Dictionary = CreateObject("scripting.dictionary")
    Sheet1.Activate
    lastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To lastRow
        If Len(Cells(i, "A")) <> 0 Then
            If Not Dictionary.exists(Cells(i, "A").Value) Then
                Dictionary.Add Cells(i, "A").Value, VBA.Array(Cells(i, "A").Value, 0)
            End If
            w = Dictionary(Cells(i, "A").Value)
            w(1) = w(1) + 1
            Dictionary(Cells(i, "A").Value) = w
        End If
    Next
    Sheets(1).Range("C1") = Dictionary.Count
    Sheets(1).Range("B2").Resize(Dictionary.Count, 2).Value = _
    Application.Index(Dictionary.items, 0, 0)
   
    Application.ScreenUpdating = True
   
    MsgBox Dictionary.Count & " unique cell(s) were found and copied."

End Sub
 
YasserKhalil said:
Try this
Code: 
Sub UniqueList()
'The Code Extracts The Unique Values From Column A And Put Unique Values In Column B
'-----------------------------------------------------------------------------------
    'Declare Variables
    Dim I As Long
    Dim lastRow As Long
    Dim dictionary As Object

    'Set The Variable To Hold Dictionary Object (Used To Hold Unique Values Only)
    Set dictionary = CreateObject("scripting.dictionary")

    'Determine The Last Row In Column A
    lastRow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

    'Disable Screen Updating
    Application.ScreenUpdating = False

        'If The Value That Will Be Added To The Dictionary Is Existing Then It
        'Produces An Error And This Line To Avoid The Error Message
        On Error Resume Next
  
        'Loop Through Rows 1 To Last Row In Column A
        For I = 1 To lastRow
  
            'Check If The Cell Is Not Empty
            If Len(Cells(I, "A")) <> 0 Then
  
                'If The Cell Is Not Empty Then Add The Value Of The Cell To The Dictionary
                dictionary.Add Cells(I, "A").Value, 1
            End If
        Next I
  
        'Put The Number Of The Dictionary Keys In C1
        Sheets(1).Range("C1") = dictionary.Count
  
        'Put The Dictionary Keys In B1. Transpose Is Used To Put Results In Vertical Array
        Sheets(1).Range("B1").Resize(dictionary.Count).Value = Application.Transpose(dictionary.keys)

    'Enable Screen Updating
    Application.ScreenUpdating = True

    'End The Code With Displaying The Dictionary Keys (Unique Items Added)
    MsgBox dictionary.Count & " Unique Cell(s) Were Found And Copied."
End Sub
Click to expand...

------

@YasserKhalil: thanks for your replay

it is pasting count of unique value in column C properly. however not pasting unique values in column B.


Regards,
macro_learning
 
jindon said:
Perhaps
Code: 
Sub UniqueList()

    Application.ScreenUpdating = False
    Dim lastRow As Long
    Dim i As Long
    Dim Dictionary As Object, w
    Set Dictionary = CreateObject("scripting.dictionary")
    Sheet1.Activate
    lastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To lastRow
        If Len(Cells(i, "A")) <> 0 Then
            If Not Dictionary.exists(Cells(i, "A").Value) Then
                Dictionary.Add Cells(i, "A").Value, VBA.Array(Cells(i, "A").Value, 0)
            End If
            w = Dictionary(Cells(i, "A").Value)
            w(1) = w(1) + 1
            Dictionary(Cells(i, "A").Value) = w
        End If
    Next
    Sheets(1).Range("C1") = Dictionary.Count
    Sheets(1).Range("B2").Resize(Dictionary.Count, 2).Value = _
    Application.Index(Dictionary.items, 0, 0)
  
    Application.ScreenUpdating = True
  
    MsgBox Dictionary.Count & " unique cell(s) were found and copied."

End Sub
Click to expand...
------

@jindon : it is showng type mismatch error.
 
macro_learning said:
------

@jindon : it is showng type mismatch error.
Click to expand...
If still error, post a sample workbook.
Code: 
Sub UniqueList()
    Dim a, i As Long
    Dim dic As Object, w
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
        ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
        For i = 1 To UBound(a, 1)
            If Not dic.exists(a(i, 1)) Then
                dic(a(i, 1)) = dic.Count + 1
                a(dic.Count, 1) = a(i, 1)
            End If
            a(dic(a(i, 1)), 2) = a(dic(a(i, 1)), 2) + 1
        Next
        .[c1] = dic.Count
        .[b2].Resize(dic.Count, 2).Value = a
    End With
    MsgBox dic.Count & " unique cell(s) were found and copied."
End Sub
 
mohadin said:
Hi
Mr. jindon both codes are perfect
Regards
Click to expand...
Thanks for testing.

One possibility for error is Transpose function when result exceeds 65536 elements or any one element has more than 256 characters.
However the other code is running without error, so this is not the case.

Very strange.
 
You must log in or register to reply here.
Back
Top