How to create unique values counts and data driven descriptions

This macro takes existing Unique Values symbology and calculates feature counts for each value, adding the count to each Class Label. Class Labels appear in the ArcMap Table of Contents and Legend. The macro also populates each Class Description based on a separate Description Field. Class Descriptions only appear in Legends.

How to use

Add a feature layer to ArcMap and symbolize with Unique values.
Copy and paste the following code into ArcMap's VBA editor.
Modify the constants for your particular data and situation
Run the macro.
Counts will appear in the Class Labels in the ArcMap Table of Contents. Insert a Legend into the layout to see the field-driven Class Descriptions.

[VBA]


        Const DESCRIP_FIELD = "STATE_NAME"
Const CONCATENATE_TO_BUILD_DESCRIPTION = True
Const CONCAT_CHAR = vbNewLine

Option Explicit

Sub UniqueValues_LabelCount_and_DescripFromField()
    
    Dim pDoc As IMxDocument
    Set pDoc = ThisDocument
    Dim pMap As IMap
    Set pMap = pDoc.FocusMap
    Dim pGeoLayer As IGeoFeatureLayer
    Set pGeoLayer = pMap.Layer(0)
    
    If Not TypeOf pGeoLayer.Renderer Is IUniqueValueRenderer Then
        MsgBox "Current symbology is not Unique values. Exiting."
        Exit Sub
    End If
    
    Dim pUVRend As IUniqueValueRenderer
    Set pUVRend = pGeoLayer.Renderer
    
    If pUVRend.FieldCount > 1 Then
        MsgBox "Current Unique values symbology is based on multiple fields. Exiting."
        Exit Sub
    End If
    
    Dim sFieldName As String
    sFieldName = pUVRend.Field(0)
    
    Dim i As Integer
    Dim varValue As Variant
    
    Dim pFeatClass As IFeatureClass
    Set pFeatClass = pGeoLayer.FeatureClass
    
    Dim varLabelDescrip As Variant
    For i = 0 To pUVRend.ValueCount - 1
        varValue = pUVRend.Value(i)
        varLabelDescrip = GetLabelDescription(pFeatClass, pUVRend.Field(0), varValue)
        pUVRend.Label(varValue) = varLabelDescrip(0)
        pUVRend.Description(varValue) = varLabelDescrip(1)
    Next i
    
    pDoc.ActiveView.ContentsChanged
    pDoc.UpdateContents
    pDoc.ActiveView.Refresh
End Sub

Private Function GetLabelDescription(pFeatClass As IFeatureClass, ValField As String, Value As Variant) As Variant
    ' returns an array of length 2
    ' (0) is the new label (string) appended with count of features
    ' (1) is the new descrip (string) driven from DESCRIP_FIELD
    
    Dim pQueryFilter As IQueryFilter
    Set pQueryFilter = New QueryFilter
    
    pQueryFilter.WhereClause = ValField & " = '" & CStr(Value) & "'"
    pQueryFilter.AddField DESCRIP_FIELD
    Dim pFeatCursor As IFeatureCursor
    Set pFeatCursor = pFeatClass.Search(pQueryFilter, False)
    
    ' ---------------------------------------------------------
    ' Description
    Dim pFeat As IFeature
    Dim sDescrip As String
    Dim iDescrip As Integer
    iDescrip = pFeatClass.Fields.FindField(DESCRIP_FIELD)
    Set pFeat = pFeatCursor.NextFeature
    
    Dim iCount As Integer
    iCount = 0
    Dim bCountsDetermined As Boolean
    bCountsDetermined = False
    
    If CONCATENATE_TO_BUILD_DESCRIPTION Then
        bCountsDetermined = True
        Do While Not pFeat Is Nothing
            iCount = iCount + 1
            If sDescrip <> "" Then sDescrip = sDescrip + CONCAT_CHAR
            sDescrip = sDescrip + CStr(pFeat.Value(iDescrip)) ' get value from DESCRIP_FIELD
            Set pFeat = pFeatCursor.NextFeature
        Loop
        
    Else ' only get descrip from first feature found
        If Not pFeat Is Nothing Then
            sDescrip = CStr(pFeat.Value(iDescrip)) ' get value from DESCRIP_FIELD
        End If
        
    End If
    
    ' ---------------------------------------------------------
    ' Label
    If Not bCountsDetermined Then
        ' optimization:  re-query only if we don't
        '   already have the counts from above
        iCount = pFeatClass.FeatureCount(pQueryFilter)
    End If
    Dim sLabel As String
    sLabel = Value & " (" & iCount & ") "
    
    ' ---------------------------------------------------------
    ' setup return array and return
    Dim sReturnArray(2) As String
    sReturnArray(0) = sLabel
    sReturnArray(1) = sDescrip
    
    GetLabelDescription = sReturnArray
    
End Function