Prepare hierarchical and non-numeric pivot tables in Excel

Here's the example of hierarchical data in a database:

Country	Region	Category	ProgramName	Details_1	Details_2	Details_3
USA	North	SchoolName	A	a1	a2	a3
USA	South	SchoolName	C	c1	c2	c3
Brasil	East	SchoolName	D	d1	d2	d3
Brasil	East	CollegeName	E	e1	e2	e3
Brasil	West	CollegeName	F	f1	f2	f3

I've created both class module "CTextTransposer" and module "TestTextTransposer" in Excel.

Class module "CTextTransposer"

Code:

---

Option Explicit
PrivateConst DEFAULT_VALUES_SEPARATOR AsString=", "

Private m_rngSource As Excel.Range
Private m_dicAcrossSourceColumnIndexes AsObject'Scripting.Dictionary
Private m_dicDownSourceColumnIndexes AsObject'Scripting.Dictionary
Private m_lDataSourceColumnIndex AsLong
Private m_bRepeatAcrossHeaders AsBoolean
Private m_bRepeatDownHeaders AsBoolean
Private m_sKeySeparator AsString
Private m_sValuesSeparator AsString

PrivateSub Class_Initialize()
    Set m_dicAcrossSourceColumnIndexes = CreateObject("Scripting.Dictionary")
    Set m_dicDownSourceColumnIndexes = CreateObject("Scripting.Dictionary")
    m_sKeySeparator = ChrW(&HFFFF)
    m_sValuesSeparator = DEFAULT_VALUES_SEPARATOR
EndSub

PrivateSub Class_Terminate()
    OnErrorResumeNext
    Set m_rngSource =Nothing
    Set m_dicAcrossSourceColumnIndexes =Nothing
    Set m_dicDownSourceColumnIndexes =Nothing
EndSub

PublicSub Init(ByVal prngSource As Excel.Range)
    Set m_rngSource = prngSource
EndSub

PublicSub SetAcross(ByVal psSourceColumnHeader AsString)
    StoreHeaderColumnIndex m_dicAcrossSourceColumnIndexes, psSourceColumnHeader
EndSub

PublicSub SetDown(ByVal psSourceColumnHeader AsString)
    StoreHeaderColumnIndex m_dicDownSourceColumnIndexes, psSourceColumnHeader
EndSub

PublicSub SetData(ByVal psSourceColumnHeader AsString)
    m_lDataSourceColumnIndex = GetHeaderColumnIndex(psSourceColumnHeader)
EndSub

PublicPropertyLet RepeatAcrossHeaders(ByVal value AsBoolean)
    m_bRepeatAcrossHeaders = value
EndProperty

PublicPropertyGet RepeatAcrossHeaders()AsBoolean
    RepeatAcrossHeaders = m_bRepeatAcrossHeaders
EndProperty

PublicPropertyLet RepeatDownHeaders(ByVal value AsBoolean)
    m_bRepeatDownHeaders = value
EndProperty

PublicPropertyGet RepeatDownHeaders()AsBoolean
    RepeatDownHeaders = m_bRepeatDownHeaders
EndProperty

PublicPropertyLet ValuesSeparator(ByVal value AsString)
    m_sValuesSeparator = value
EndProperty

PublicPropertyGet ValuesSeparator()AsString
    ValuesSeparator = m_sValuesSeparator
EndProperty

PrivateSub StoreHeaderColumnIndex(ByRef pdicTarget AsObject,ByVal psColumnHeader AsString)
    pdicTarget(GetHeaderColumnIndex(psColumnHeader))=True
EndSub

PrivateFunction GetHeaderColumnIndex(ByVal psColumnHeader AsString)AsLong
    GetHeaderColumnIndex = Application.WorksheetFunction.Match(psColumnHeader, m_rngSource.Rows(1),0)
EndFunction

PublicSub 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 AsObject'Scripting.Dictionary
    Dim dicDownArrays AsObject'Scripting.Dictionary
    Dim dicDistinctAcross AsObject'Scripting.Dictionary
    Dim dicDistinctDown AsObject'Scripting.Dictionary
    Dim vntSourceData AsVariant
    Dim vntSourceColumnIndex AsVariant
    Dim lSourceRowIndex AsLong
    Dim lDestinationColumnIndex AsLong
    Dim lDestinationRowIndex AsLong
    Dim sAcrossKey AsString
    Dim sDownKey AsString
    Dim vntKey AsVariant
    Dim vntKeyParts AsVariant
    Dim lKeyPartIndex AsLong

    If m_rngSource IsNothingThen
        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 =1Then
        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(1To1,1To m_dicDownSourceColumnIndexes.Count)AsVariant
        lDestinationColumnIndex =1
        ForEach 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(1To m_dicAcrossSourceColumnIndexes.Count,1To dicDistinctAcross.Count)AsVariant
        lDestinationColumnIndex =1
        ForEach vntKey In dicDistinctAcross.Keys
            vntKeyParts = Split(vntKey, m_sKeySeparator, Compare:=vbBinaryCompare)
            For lKeyPartIndex =0To UBound(vntKeyParts)
                acrossColumnHeaders(lKeyPartIndex +1, lDestinationColumnIndex)= vntKeyParts(lKeyPartIndex)
            Next
            lDestinationColumnIndex = lDestinationColumnIndex +1
        Next
        IfNot m_bRepeatAcrossHeaders Then
            For lDestinationRowIndex =1To m_dicAcrossSourceColumnIndexes.Count
                For lDestinationColumnIndex = dicDistinctAcross.Count To2Step-1
                    If acrossColumnHeaders(lDestinationRowIndex, lDestinationColumnIndex)= acrossColumnHeaders(lDestinationRowIndex, lDestinationColumnIndex -1)Then
                        acrossColumnHeaders(lDestinationRowIndex, lDestinationColumnIndex)= Empty
                    EndIf
                Next
            Next
        EndIf
        Set prngAcrossColumnHeaders = prngDestinationTopLeftCell.Cells(1, m_dicDownSourceColumnIndexes.Count +1).Resize(m_dicAcrossSourceColumnIndexes.Count, dicDistinctAcross.Count)
        prngAcrossColumnHeaders.value = acrossColumnHeaders

        'Down row headers.
        ReDim downRowHeaders(1To dicDistinctDown.Count,1To m_dicDownSourceColumnIndexes.Count)AsVariant
        lDestinationRowIndex =1
        ForEach vntKey In dicDistinctDown.Keys
            vntKeyParts = Split(vntKey, m_sKeySeparator, Compare:=vbBinaryCompare)
            For lKeyPartIndex =0To UBound(vntKeyParts)
                downRowHeaders(lDestinationRowIndex, lKeyPartIndex +1)= vntKeyParts(lKeyPartIndex)
            Next
            lDestinationRowIndex = lDestinationRowIndex +1
        Next
        IfNot m_bRepeatDownHeaders Then
            For lDestinationRowIndex = dicDistinctDown.Count To2Step-1
                For lDestinationColumnIndex =1To m_dicDownSourceColumnIndexes.Count
                    If downRowHeaders(lDestinationRowIndex, lDestinationColumnIndex)= downRowHeaders(lDestinationRowIndex -1, lDestinationColumnIndex)Then
                        downRowHeaders(lDestinationRowIndex, lDestinationColumnIndex)= Empty
                    EndIf
                Next
            Next
        EndIf
        Set prngRowColumnHeaders = prngDestinationTopLeftCell.Cells(m_dicAcrossSourceColumnIndexes.Count +1,1).Resize(dicDistinctDown.Count, m_dicDownSourceColumnIndexes.Count)
        prngRowColumnHeaders.value = downRowHeaders

        'Data.
        ReDim vntDestinationData(1To dicDistinctDown.Count,1To dicDistinctAcross.Count)AsVariant
        For lSourceRowIndex =2To 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 =1To dicDistinctDown.Count
            For lDestinationColumnIndex =1To dicDistinctAcross.Count
                IfNot IsEmpty(vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex))Then
                    vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex)= Mid$(vntDestinationData(lDestinationRowIndex, lDestinationColumnIndex), Len(m_sValuesSeparator)+1)
                EndIf
            Next
        Next
        Set prngData = prngDestinationTopLeftCell.Cells(1+ m_dicAcrossSourceColumnIndexes.Count,1+ m_dicDownSourceColumnIndexes.Count).Resize(dicDistinctDown.Count, dicDistinctAcross.Count)
        prngData.value = vntDestinationData
    EndIf

    Set dicAcrossArrays =Nothing
    Set dicDownArrays =Nothing
    Set dicDistinctAcross =Nothing
    Set dicDistinctDown =Nothing
EndSub

PrivateSub InitColumnIndexDictionaries(ByVal pdicSourceColumnIndexes AsObject,ByRef pdicArrays AsObject,ByRef pdicDistinct AsObject)
    Dim vntSourceColumnIndex AsVariant
    Dim lSourceRowIndex AsLong
    Dim sKey AsString

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

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

    For lSourceRowIndex =2To m_rngSource.Rows.Count
        sKey = GetKey(pdicSourceColumnIndexes, pdicArrays, lSourceRowIndex)
        IfNot pdicDistinct.Exists(sKey)Then
            pdicDistinct(sKey)= pdicDistinct.Count +1
        EndIf
    Next
EndSub

PrivateFunction GetKey(ByVal pdicSourceColumnIndexes AsObject,ByVal pdicArrays AsObject,ByVal plSourceRowIndex AsLong)AsString
    Dim sResult AsString
    Dim vntSourceColumnIndex AsVariant

    sResult =""

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

    GetKey = sResult
EndFunction

---

Module "TestTextTransposer"

Code:

---

Option Explicit

PublicSub TestTextTransposer()
    OnErrorGoTo 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"

        .SetData "ProgramName"

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

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

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

Recover:
    OnErrorResumeNext
    Set rngData =Nothing
    Set rngDownRowHeaders =Nothing
    Set rngAcrossColumnHeaders =Nothing
    Set rngDownColumnHeaders =Nothing
    Set oTT =Nothing
    Application.EnableEvents =True
    Application.ScreenUpdating =True
    ExitSub

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

---

Run the TestTextTransposer macro and the results will be shown on Sheet1, cell H10. I would like to seek your kind assistance to give advice for enhancing the pivot table with more data fields (highlighted in red below) look like this:

Category

USA

Brasil

North

South

East

West

ProgramName

Details_1

Details_2

Details_3

ProgramName

Details_1

Details_2

Details_3

ProgramName

Details_1

Details_2

Details_3

ProgramName

Details_1

Details_2

Details_3

SchoolName

A

a1

a2

a3

C

c1

c2

c3

D

d1

d2

d3

CollegeName

E

e1

e2

e3

F

f1

f2

f3

Any comments/suggestions would be much appreciated.

To everyone,

I've appended my working file for your easy reference. Thanks!

Attachment 25401

I don't see your problem.
No VBA required.

Thanks for your reply. Actually I was expecting the pivot table format by adding Country and Region fields to the columns instead of rows.

With what benefit ?

Thanks, snb. Just want to place the same category with different countries and locations directly side by side to make it easier for comparison if there are a lot of data.

I think the suggestion I provided serves that purpose better.