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.