Consulting

Results 1 to 7 of 7

Thread: Prepare hierarchical and non-numeric pivot tables in Excel

  1. #1

    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"
    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"
    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.

  2. #2

    Post

    To everyone,

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

    TextTransposer.xlsm

  3. #3
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,660
    I don't see your problem.
    No VBA required.
    Attached Files Attached Files

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

  5. #5
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,660
    With what benefit ?

  6. #6
    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.

  7. #7
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,660
    I think the suggestion I provided serves that purpose better.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •