Posts Tagged ‘Unique’

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

Unique Values From Data Using VBA Dictionary Object

Posted: April 19, 2013 by MaxFraudy in Excel, VBA
Tags: , ,

Very often when we are working with huge amount of data, many a times we need to get unique values from a list. e.g. from region-wise sales data, a unique list of product names. Also, when using form controls like a dropdown (combobox) or a list box, we want to get unique values from a range that will be used as input for that control. While there are many ways to get this done, perhaps the most efficient one is using dictionary objects.

The program written below does exactly as required (Thanks to Transformer for his code). It is a parameterised function that takes the following arguments:

   varSource = source data from which unique values are to be extracted
   blnPaste = TRUE if you want the result to be pasted to a range, 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 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

If IsArray(varSource) Then  'proceeding only if the array is non-empty
    Set objDictionary = CreateObject("Scripting.Dictionary")

    With objDictionary
        For lngLoop = LBound(varSource) To UBound(varSource)

            If blnCase Then
                strKey = varSource(lngLoop)
            Else
                strKey = StrConv(varSource(lngLoop), vbProperCase)
            End If
        .Item(strKey) = .Item(strKey) + 1 'counting occurences
        Next lngLoop

        If blnCounts Then
            varUniqueList = Array(.keys, .items)
        Else
            varUniqueList = Array(.keys)
        End If

        'pasting results in destination range
        If blnPaste And Not rngDest Is Nothing Then 
            rngDest.Resize(.Count, 1-blnCounts).Value = Application.Transpose(varUniqueList)
        End If
    End With

    Set objDictionary = Nothing
Else
    Exit Function
End If

End Function
 

This function can be called from any other procedure like below. Here rngSource is the range which contains the data and rngDest is the range where results are to be pasted.

Sub Start() 
Dim varData      As Variant 
Dim varResult    As Variant 
Dim rngRes       As Range 

    With ThisWorkbook.Worksheets("Sheet1") 
        vardata = Application.Transpose(.Range("rngSource")) 
        Set rngRes = .Range("rngDest") 
        Call varUniqueList(varData, True, rngRes) 'for pasting data
        varResult = varUniqueList(varData)        'result array
    End With 
End Sub