Excel 2013 年数据透视分层、非数值数据
Excel 2013 pivot hierarchical, nonnumerical data
我有这样的分层数据
Country Region Category ProgramName
USA North SchoolName A
USA North SchoolName B
USA South SchoolName C
Brasil East SchoolName D
Brasil East CollegeName E
Brasil West CollegeName F
我想将其转换为用户可读的格式。
我能够构建主元 table，但是我想使用非数字数据作为主元。 看起来很有希望，但它只能旋转一个非分层列。我怎样才能实现我的目标？
所以从你的回答来看，你想要这样：
但数据透视表实际上为您提供了一种更好的方式来以原生方式查看完全相同的信息，如下所示：
...好处是那些 G 行没有重复...相反您得到一个计数。但除此之外，您可以从两者中获得完全相同的信息。您不想要 'native' 数据透视表布局的任何特定原因？
我无法在网上找到代码来完成您正在寻找的事情。通过一些 Get & Transform 法术也许可以，但这不是我的专业领域。因为这是一个有趣的问题，而且因为我可以为我自己的项目想到用例，所以这是我的看法。
免责声明：这段代码还没有经过全面测试。使用风险自负。
首先，创建一个新工作簿，并在 Sheet1 上从单元格 A1 开始设置这些值（出于测试目的，我添加了 SubCategory 列）：
Country Region Category SubCategory ProgramName
USA North SchoolName X A
USA North SchoolName X B
USA South SchoolName Y C
Brasil East SchoolName Y D
Brasil East CollegeName X E
Brasil West CollegeName Y F
然后，创建一个名为 CTextTransposer 的 class 模块并将此代码粘贴到其中：
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
最后，创建一个模块并将此代码粘贴到其中：
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"
.SetDown "SubCategory"
.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
运行 TestTextTransposer 子并观察从 Sheet1 单元格 H10 开始的结果。查看测试代码，您会发现我已经使用了 class 提供的所有选项，另外我还使用了 returns 的范围来进行一些基本格式化。
我不会在这里解释所有细节，但您会看到它归结为一些字典和一些数组操作。希望对你有帮助。
注意：如前所述，classe 的字符串键控词典区分大小写，因此在准备源数据时必须牢记这一点。这可以通过将另一个 属性 添加到 class.
来轻松参数化
这是最终结果（应用了更多格式）：
我有这样的分层数据
Country Region Category ProgramName
USA North SchoolName A
USA North SchoolName B
USA South SchoolName C
Brasil East SchoolName D
Brasil East CollegeName E
Brasil West CollegeName F
我想将其转换为用户可读的格式。
我能够构建主元 table，但是我想使用非数字数据作为主元。
所以从你的回答来看，你想要这样：
但数据透视表实际上为您提供了一种更好的方式来以原生方式查看完全相同的信息，如下所示：
...好处是那些 G 行没有重复...相反您得到一个计数。但除此之外，您可以从两者中获得完全相同的信息。您不想要 'native' 数据透视表布局的任何特定原因？
我无法在网上找到代码来完成您正在寻找的事情。通过一些 Get & Transform 法术也许可以，但这不是我的专业领域。因为这是一个有趣的问题，而且因为我可以为我自己的项目想到用例，所以这是我的看法。
免责声明：这段代码还没有经过全面测试。使用风险自负。
首先，创建一个新工作簿，并在 Sheet1 上从单元格 A1 开始设置这些值（出于测试目的，我添加了 SubCategory 列）：
Country Region Category SubCategory ProgramName
USA North SchoolName X A
USA North SchoolName X B
USA South SchoolName Y C
Brasil East SchoolName Y D
Brasil East CollegeName X E
Brasil West CollegeName Y F
然后，创建一个名为 CTextTransposer 的 class 模块并将此代码粘贴到其中：
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
最后，创建一个模块并将此代码粘贴到其中：
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"
.SetDown "SubCategory"
.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
运行 TestTextTransposer 子并观察从 Sheet1 单元格 H10 开始的结果。查看测试代码，您会发现我已经使用了 class 提供的所有选项，另外我还使用了 returns 的范围来进行一些基本格式化。
我不会在这里解释所有细节，但您会看到它归结为一些字典和一些数组操作。希望对你有帮助。
注意：如前所述，classe 的字符串键控词典区分大小写，因此在准备源数据时必须牢记这一点。这可以通过将另一个 属性 添加到 class.
来轻松参数化这是最终结果（应用了更多格式）：