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