Excel/VBA Pivoting a column and listing all unique values under column regardless of of number in other columns

Pivot Column Using a Dictionary of Dictionaries

• Adjust the values in the constants section.

Option Explicit

Sub PivotColumn()
    Const ProcName As String = "PivotColumn"
    On Error GoTo ClearError ' cover unexpected errors

    ' Source
    Const sName As String = "Sheet1"
    Const sPivotColumnFirstCellAddress As String = "A2"
    Const sValuesWorksheetColumnIndex As Variant = "B" ' or 2
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A1"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the source column values to arrays.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim sprg As Range
    Dim srCount As Long
    
    With sws.Range(sPivotColumnFirstCellAddress)
        Dim splCell As Range
        Set splCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If splCell Is Nothing Then
            MsgBox "No data in pivot column range.", vbCritical
            Exit Sub
        End If
        srCount = splCell.Row - .Row + 1
        Set sprg = .Resize(srCount)
    End With
    
    Dim svrg As Range
    Set svrg = sprg.EntireRow.Columns(sValuesWorksheetColumnIndex)
    
    Dim spData As Variant
    Dim svData As Variant
    
    If srCount = 1 Then ' one row
        ReDim spData(1 To 1, 1 To 1): spData(1, 1) = sprg.Value
        ReDim svData(1 To 1, 1 To 1): svData(1, 1) = svrg.Value
    Else ' multiple rows
        spData = sprg.Value
        svData = svrg.Value
    End If
    
    ' Write the unique source column values from the arrays
    ' to a dictionary of dictionaries.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim pKey As Variant
    Dim vKey As Variant
    Dim sr As Long
    Dim drCount As Long
    
    For sr = 1 To srCount
        pKey = spData(sr, 1)
        If Not IsError(pKey) Then ' exclude error values
            If Len(pKey) > 0 Then ' exclude blanks
                vKey = svData(sr, 1)
                If Not IsError(vKey) Then ' exclude error values
                    If Len(vKey) > 0 Then ' exclude blanks
                        If Not dict.Exists(pKey) Then
                            Set dict(pKey) _
                                = CreateObject("Scripting.Dictionary")
                        End If
                        dict(pKey)(vKey) = Empty
                        If dict(pKey).Count > drCount Then
                            drCount = dict(pKey).Count
                        End If
                    End If
                End If
            End If
        End If
    Next sr
    
    If drCount = 0 Then
        MsgBox "No valid data found.", vbCritical
        Exit Sub
    End If
    
    ' Write the unique values from the dictionary to an array.
    
    Erase spData
    Erase svData
    
    drCount = drCount + 1  ' rows (include headers)
    Dim dcCount As Long: dcCount = dict.Count ' columns
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim dr As Long
    Dim dc As Long
    
    For Each pKey In dict.Keys
        dc = dc + 1
        dData(1, dc) = pKey
        dr = 1
        For Each vKey In dict(pKey).Keys
            dr = dr + 1
            dData(dr, dc) = vKey
            'Debug.Print pKey, vKey
        Next vKey
    Next pKey
    
    ' Write the values from the array to the destination worksheet.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        ' Clear previous data below and to the right of the first cell
        ' (cells above and to the left stay intact).
        .Resize(dws.Rows.Count - .Row + 1, dws.Columns.Count - .Column + 1) _
            .Clear
        ' Write.
        .Resize(drCount).Value = dData
        ' Format.
        .Font.Bold = True ' headers
        .EntireColumn.AutoFit ' columns
    End With
    
    MsgBox "Column pivoted.", vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit

End Sub