PDA

View Full Version : Prepare hierarchical and non-numeric pivot tables in Excel



nelsonlauo
11-14-2019, 09:00 PM
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
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

Module "TestTextTransposer"


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"

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

nelsonlauo
11-15-2019, 03:13 AM
To everyone,

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

25401

snb
11-15-2019, 04:25 AM
I don't see your problem.
No VBA required.

nelsonlauo
11-15-2019, 10:11 AM
Thanks for your reply. Actually I was expecting the pivot table format by adding Country and Region fields to the columns instead of rows.

snb
11-15-2019, 02:59 PM
With what benefit ?

nelsonlauo
11-16-2019, 10:11 PM
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.

snb
11-17-2019, 03:29 AM
I think the suggestion I provided serves that purpose better.