Unique List Using Dictionary Object

Posted: April 30, 2013 by Transformer in Excel, VBA
Tags: , , , ,

This function is an advanced version of  Unique Values From Data Using VBA Dictionary Object .

Following are the enhancements:

1. Now the Source data can be a Range or an Array
2. User have choice to paste data whether one wants to paste it in Columns or in Rows
3.Now It can be called from the Worksheet also and will work as an Array function

It takes the following arguments:
varSource = source data from which unique values are to be extracted.It Can be a Range or an Array
blnPaste = TRUE if you want the result to be pasted to a range, FALSE by default
blnPasteHorizontally = TRUE if you want the result to be pasted in a Row , FALSE by default
rngDest = range where the results are to be pasted
blnCase = TRUE if the list is to case-sensitive, FALSE by default. The results will be in proper case for FALSE
blnCounts = TRUE if you want to see the number of occurrences of each item as well, FALSE by default


Function varUniqueList(varSource As Variant, _
                   Optional blnPaste As Boolean = False, _
                   Optional blnPasteHorizontally As Boolean = False, _
                   Optional rngDest As Range, _
                   Optional blnCase As Boolean = True, _
                   Optional blnCounts As Boolean = False)

    Dim lngLoop                 As Long
    Dim strKey                  As String
    Dim objDictionary           As Object
    Dim varSourceTemp           As Variant
    Dim blnSheetCall            As Boolean

    Application.Volatile
    On Error Resume Next
    If TypeName(Application.Caller) = "Range" Then blnSheetCall = True
    On Error GoTo 0
    If TypeName(varSource) = "Range" Then
        If varSource.Rows.Count > 1 Then
            varSourceTemp = Application.Transpose(varSource)
        Else
            varSourceTemp = Application.Transpose(Application.Transpose(varSource))
        End If
    Else
        varSourceTemp = varSource
    End If

    If Not IsArray(varSourceTemp) Then Exit Function 'Proceeding only if the array is non-empty
    Set objDictionary = CreateObject("Scripting.Dictionary")
    With objDictionary
        For lngLoop = LBound(varSourceTemp) To UBound(varSourceTemp)
            If blnCase Then
                strKey = varSourceTemp(lngLoop)
            Else
                strKey = StrConv(varSourceTemp(lngLoop), vbProperCase)
            End If
            .Item(strKey) = .Item(strKey) + 1 'Counting occurences
        Next lngLoop
        If blnCounts Then
            varSourceTemp = Application.Transpose(Array(.keys, .items))
        Else
            varSourceTemp = Application.Transpose(Array(.keys))
        End If

        If blnSheetCall = True Then blnPasteHorizontally = Not blnPasteHorizontally
        If blnPasteHorizontally = True Then
            varUniqueList = varSourceTemp
        Else
            varUniqueList = Application.Transpose(varSourceTemp)
        End If

        'Pasting results in destination range
        If blnPaste And Not rngDest Is Nothing Then
            If blnPasteHorizontally = True Then
                rngDest.Resize(1 - blnCounts, .Count).Value = Application.Transpose(varSourceTemp)
            Else
                rngDest.Resize(.Count, 1 - blnCounts).Value = varSourceTemp
            End If
        End If
    End With
    Set objDictionary = Nothing
End Function
Advertisements
Comments
  1. MaxFraudy says:

    Thanks for improving the code Transformer 🙂

Share your thoughts/feedback

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s