Excel 2013 pivot hierarchical, nonnumerical data

Question

I have hierarchical data like this

Country Region  Category       ProgramName
USA     North   SchoolName     A
USA     North   SchoolName     B
USA     South   SchoolName     C
Brasil  East    SchoolName     D
Brasil  East    CollegeName    E
Brasil  West    CollegeName    F

I would like to pivot it into a user readable format.

I am able to build the pivot table, however I would like to use nonnumeric data as the pivot. The VBA code in this answer seems promising but it can only pivot a single nonhierarchical column. How can I achieve my goal?

Answer 1

I couldn't find code lying around on the 'net to do just what you're looking for. It might be possible through some Get & Transform sorcery, but that's not my field of expertise. Because it's an interesting problem and because I can think of use cases for my own projects, here's my take on it.

Disclaimer: this code is hot off the stove and hasn't been thoroughly tested. Use at your own risk.

First, create a new workbook and, on Sheet1, set these values starting at cell A1 (I've added the SubCategory column for testing purposes):

Country Region  Category     SubCategory  ProgramName
USA     North   SchoolName   X            A
USA     North   SchoolName   X            B
USA     South   SchoolName   Y            C
Brasil  East    SchoolName   Y            D
Brasil  East    CollegeName  X            E
Brasil  West    CollegeName  Y            F

Then, create a class module named CTextTransposer and paste this code into it:

Option Explicit

Private Const DEFAULT_VALUES_SEPARATOR As String = ", "

Private m_rngSource As Excel.Range
Private m_dicAcrossSourceColumnIndexes As Object 'Scripting.Dictionary
Private m_dicDownSourceColumnIndexes As Object 'Scripting.Dictionary
Private m_lDataSourceColumnIndex As Long
Private m_bRepeatAcrossHeaders As Boolean
Private m_bRepeatDownHeaders As Boolean
Private m_sKeySeparator As String
Private m_sValuesSeparator As String

Private Sub Class_Initialize()
    Set m_dicAcrossSourceColumnIndexes = CreateObject("Scripting.Dictionary")
    Set m_dicDownSourceColumnIndexes = CreateObject("Scripting.Dictionary")
    m_sKeySeparator = ChrW(&HFFFF)
    m_sValuesSeparator = DEFAULT_VALUES_SEPARATOR
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    Set m_rngSource = Nothing
    Set m_dicAcrossSourceColumnIndexes = Nothing
    Set m_dicDownSourceColumnIndexes = Nothing
End Sub

Public Sub Init(ByVal prngSource As Excel.Range)
    Set m_rngSource = prngSource
End Sub

Public Sub SetAcross(ByVal psSourceColumnHeader As String)
    StoreHeaderColumnIndex m_dicAcrossSourceColumnIndexes, psSourceColumnHeader
End Sub

Public Sub SetDown(ByVal psSourceColumnHeader As String)
    StoreHeaderColumnIndex m_dicDownSourceColumnIndexes, psSourceColumnHeader
End Sub

Public Sub SetData(ByVal psSourceColumnHeader As String)
    m_lDataSourceColumnIndex = GetHeaderColumnIndex(psSourceColumnHeader)
End Sub

Public Property Let RepeatAcrossHeaders(ByVal value As Boolean)
    m_bRepeatAcrossHeaders = value
End Property

Public Property Get RepeatAcrossHeaders() As Boolean
    RepeatAcrossHeaders = m_bRepeatAcrossHeaders
End Property

Public Property Let RepeatDownHeaders(ByVal value As Boolean)
    m_bRepeatDownHeaders = value
End Property

Public Property Get RepeatDownHeaders() As Boolean
    RepeatDownHeaders = m_bRepeatDownHeaders
End Property

Public Property Let ValuesSeparator(ByVal value As String)
    m_sValuesSeparator = value
End Property

Public Property Get ValuesSeparator() As String
    ValuesSeparator = m_sValuesSeparator
End Property

Private Sub StoreHeaderColumnIndex(ByRef pdicTarget As Object, ByVal psColumnHeader As String)
    pdicTarget(GetHeaderColumnIndex(psColumnHeader)) = True
End Sub

Private Function GetHeaderColumnIndex(ByVal psColumnHeader As String) As Long
    GetHeaderColumnIndex = Application.WorksheetFunction.Match(psColumnHeader, m_rngSource.Rows(1), 0)
End Function

Public Sub TransposeTo( _
    ByVal prngDestinationTopLeftCell As Excel.Range, _
    ByRef prngDownColumnHeaders As Excel.Range, _
    ByRef prngAcrossColumnHeaders As Excel.Range, _
    ByRef prngRowColumnHeaders As Excel.Range, _
    ByRef prngData As Excel.Range)

    Dim dicAcrossArrays As Object 'Scripting.Dictionary
    Dim dicDownArrays As Object 'Scripting.Dictionary
    Dim dicDistinctAcross As Object 'Scripting.Dictionary
    Dim dicDistinctDown As Object 'Scripting.Dictionary
    Dim vntSourceData As Variant
    Dim vntSourceColumnIndex As Variant
    Dim lSourceRowIndex As Long
    Dim lDestinationColumnIndex As Long
    Dim lDestinationRowIndex As Long
    Dim sAcrossKey As String
    Dim sDownKey As String
    Dim vntKey As Variant
    Dim vntKeyParts As Variant
    Dim lKeyPartIndex As Long

    If m_rngSource Is Nothing Then
        prngDestinationTopLeftCell.Value2 = "(Not initialized)"
    ElseIf (m_dicAcrossSourceColumnIndexes.Count = 0) Or (m_dicDownSourceColumnIndexes.Count = 0) Or (m_lDataSourceColumnIndex = 0) Then
        prngDestinationTopLeftCell.Value2 = "(Not configured)"
    ElseIf m_rngSource.Rows.Count = 1 Then
        prngDestinationTopLeftCell.Value2 = "(No data)"
    Else
        InitColumnIndexDictionaries m_dicAcrossSourceColumnIndexes, dicAcrossArrays, dicDistinctAcross
        InitColumnIndexDictionaries m_dicDownSourceColumnIndexes, dicDownArrays, dicDistinctDown
        vntSourceData = m_rngSource.Columns(m_lDataSourceColumnIndex)

        'Down column headers.
        ReDim downColumnHeaders(1 To 1, 1 To m_dicDownSourceColumnIndexes.Count) As Variant
        lDestinationColumnIndex = 1
        For Each vntSourceColumnIndex In m_dicDownSourceColumnIndexes.Keys
            downColumnHeaders(1, lDestinationColumnIndex) = m_rngSource.Cells(1, vntSourceColumnIndex).value
            lDestinationColumnIndex = lDestinationColumnIndex + 1
        Next
        Set prngDownColumnHeaders = prngDestinationTopLeftCell.Resize(1, m_dicDownSourceColumnIndexes.Count)
        prngDownColumnHeaders.value = downColumnHeaders

        'Across column headers.
        ReDim acrossColumnHeaders(1 To m_dicAcrossSourceColumnIndexes.Count, 1 To dicDistinctAcross.Count) As Variant
        lDestinationColumnIndex = 1
        For Each vntKey In dicDistinctAcross.Keys
            vntKeyParts = Split(vntKey, m_sKeySeparator, Compare:=vbBinaryCompare)
            For lKeyPartIndex = 0 To UBound(vntKeyParts)
                acrossColumnHeaders(lKeyPartIndex + 1, lDestinationColumnIndex) = vntKeyParts(lKeyPartIndex)
            Next
            lDestinationColumnIndex = lDestinationColumnIndex + 1
        Next
        If Not m_bRepeatAcrossHeaders Then
            For lDestinationRowIndex = 1 To m_dicAcrossSourceColumnIndexes.Count
                For lDestinationColumnIndex = dicDistinctAcross.Count To 2 Step -1
                    If acrossColumnHeaders(lDestinationRowIndex, lDestinationColumnIndex) = acrossColumnHeaders(lDestinationRowIndex, lDestinationColumnIndex - 1) Then
                        acrossColumnHeaders(lDestinationRowIndex, lDestinationColumnIndex) = Empty
                    End If
                Next
            Next
        End If
        Set prngAcrossColumnHeaders = prngDestinationTopLeftCell.Cells(1, m_dicDownSourceColumnIndexes.Count + 1).Resize(m_dicAcrossSourceColumnIndexes.Count, dicDistinctAcross.Count)
        prngAcrossColumnHeaders.value = acrossColumnHeaders

        'Down row headers.
        ReDim downRowHeaders(1 To dicDistinctDown.Count, 1 To m_dicDownSourceColumnIndexes.Count) As Variant
        lDestinationRowIndex = 1
        For Each vntKey In dicDistinctDown.Keys
            vntKeyParts = Split(vntKey, m_sKeySeparator, Compare:=vbBinaryCompare)
            For lKeyPartIndex = 0 To UBound(vntKeyParts)
                downRowHeaders(lDestinationRowIndex, lKeyPartIndex + 1) = vntKeyParts(lKeyPartIndex)
            Next
            lDestinationRowIndex = lDestinationRowIndex + 1
        Next
        If Not m_bRepeatDownHeaders Then
            For lDestinationRowIndex = dicDistinctDown.Count To 2 Step -1
                For lDestinationColumnIndex = 1 To m_dicDownSourceColumnIndexes.Count
                    If downRowHeaders(lDestinationRowIndex, lDestinationColumnIndex) = downRowHeaders(lDestinationRowIndex - 1, lDestinationColumnIndex) Then
                        downRowHeaders(lDestinationRowIndex, lDestinationColumnIndex) = Empty
                    End If
                Next
            Next
        End If
        Set prngRowColumnHeaders = prngDestinationTopLeftCell.Cells(m_dicAcrossSourceColumnIndexes.Count + 1, 1).Resize(dicDistinctDown.Count, m_dicDownSourceColumnIndexes.Count)
        prngRowColumnHeaders.value = downRowHeaders

        'Data.
        ReDim vntDestinationData(1 To dicDistinctDown.Count, 1 To dicDistinctAcross.Count) As Variant
        For lSourceRowIndex = 2 To m_rngSource.Rows.Count
            sAcrossKey = GetKey(m_dicAcrossSourceColumnIndexes, dicAcrossArrays, lSourceRowIndex)
            sDownKey = GetKey(m_dicDownSourceColumnIndexes, dicDownArrays, lSourceRowIndex)
            lDestinationColumnIndex = dicDistinctAcross(sAcrossKey)
            lDestinationRowIndex = dicDistinctDown(sDownKey)
            vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex) = vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex) & m_sValuesSeparator & vntSourceData(lSourceRowIndex, 1)
        Next
        For lDestinationRowIndex = 1 To dicDistinctDown.Count
            For lDestinationColumnIndex = 1 To dicDistinctAcross.Count
                If Not IsEmpty(vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex)) Then
                    vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex) = Mid$(vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex), Len(m_sValuesSeparator) + 1)
                End If
            Next
        Next
        Set prngData = prngDestinationTopLeftCell.Cells(1 + m_dicAcrossSourceColumnIndexes.Count, 1 + m_dicDownSourceColumnIndexes.Count).Resize(dicDistinctDown.Count, dicDistinctAcross.Count)
        prngData.value = vntDestinationData
    End If

    Set dicAcrossArrays = Nothing
    Set dicDownArrays = Nothing
    Set dicDistinctAcross = Nothing
    Set dicDistinctDown = Nothing
End Sub

Private Sub InitColumnIndexDictionaries(ByVal pdicSourceColumnIndexes As Object, ByRef pdicArrays As Object, ByRef pdicDistinct As Object)
    Dim vntSourceColumnIndex As Variant
    Dim lSourceRowIndex As Long
    Dim sKey As String

    Set pdicArrays = CreateObject("Scripting.Dictionary")
    Set pdicDistinct = CreateObject("Scripting.Dictionary")

    For Each vntSourceColumnIndex In pdicSourceColumnIndexes.Keys
        pdicArrays(vntSourceColumnIndex) = m_rngSource.Columns(vntSourceColumnIndex).value
    Next

    For lSourceRowIndex = 2 To m_rngSource.Rows.Count
        sKey = GetKey(pdicSourceColumnIndexes, pdicArrays, lSourceRowIndex)
        If Not pdicDistinct.Exists(sKey) Then
            pdicDistinct(sKey) = pdicDistinct.Count + 1
        End If
    Next
End Sub

Private Function GetKey(ByVal pdicSourceColumnIndexes As Object, ByVal pdicArrays As Object, ByVal plSourceRowIndex As Long) As String
    Dim sResult As String
    Dim vntSourceColumnIndex As Variant

    sResult = ""

    For Each vntSourceColumnIndex In pdicSourceColumnIndexes.Keys
        sResult = sResult & m_sKeySeparator & CStr(pdicArrays(vntSourceColumnIndex)(plSourceRowIndex, 1))
    Next
    sResult = Mid(sResult, 2)

    GetKey = sResult
End Function

Finally, create a module and paste this code into it:

Option Explicit

Public Sub TestTextTransposer()
    On Error GoTo errHandler

    Dim oTT As CTextTransposer
    Dim rngDownColumnHeaders As Excel.Range
    Dim rngAcrossColumnHeaders As Excel.Range
    Dim rngDownRowHeaders As Excel.Range
    Dim rngData As Excel.Range

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set oTT = New CTextTransposer
    With oTT
        .Init Sheet1.Cells(1, 1).CurrentRegion

        .SetAcross "Country"
        .SetAcross "Region"

        .SetDown "Category"
        .SetDown "SubCategory"

        .SetData "ProgramName"

        .RepeatAcrossHeaders = False
        .RepeatDownHeaders = False
        .ValuesSeparator = vbLf

        .TransposeTo Sheet1.Cells(10, 8), rngDownColumnHeaders, rngAcrossColumnHeaders, rngDownRowHeaders, rngData
    End With

    Application.Union(rngDownRowHeaders, rngAcrossColumnHeaders).EntireColumn.AutoFit
    Application.Union(rngAcrossColumnHeaders, rngDownRowHeaders).EntireRow.AutoFit
    rngDownRowHeaders.VerticalAlignment = xlTop

Recover:
    On Error Resume Next
    Set rngData = Nothing
    Set rngDownRowHeaders = Nothing
    Set rngAcrossColumnHeaders = Nothing
    Set rngDownColumnHeaders = Nothing
    Set oTT = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

errHandler:
    MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
    Resume Recover
End Sub

Run the TestTextTransposer sub and observe the results starting on Sheet1, cell H10. Looking at the test code, you'll see I've used all options offered by the class, plus I've made use of the ranges it returns to do some basic formatting.

I won't explain all of the details here, but you'll see it boils down to a few dictionaries and some array manipulations. Hope it helps.

Note: as posted, the classe's dictionaries keyed by strings are case-sensitive, so your source data has to be prepared with this in mind. This can easily parameterized by adding another property to the class.

Here's the end result (with a little more formatting applied):

Answer 2

So from your answer it sounds like you want this:

But PivotTables actually give you a much better way of viewing the exact same information natively, like this:

...the bonus being that there's no repetition of those G rows...instead you get a count. But other than that, you get the exact same information from either. Any particular reason why you don't want the 'native' PivotTable layout?