Excel 2013枢轴层次结构，非数值数据 [英] Excel 2013 pivot hierarchical, nonnumerical data
本文介绍了Excel 2013枢轴层次结构，非数值数据的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我有这样的分层数据
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
我想将其转换为用户可读的格式.
I would like to pivot it into a user readable format.
我能够构建数据透视表，但是我想使用非数字数据作为数据透视表. 此答案中的VBA代码看起来很有希望，但它只能透视单个非层次列.我如何实现我的目标?
I am able to build the pivot table, however I would like to use nonnumeric data as the pivot. The VBA code in this answer seems promising but it can only pivot a single nonhierarchical column. How can I achieve my goal?
推荐答案
我找不到位于网上的代码来完成您要查找的代码.通过一些Get&可能是可能的.改变魔术，但这不是我的专业领域.因为这是一个有趣的问题，而且因为我可以想到自己项目的用例，所以我对此有所了解.
I couldn't find code lying around on the 'net to do just what you're looking for. It might be possible through some Get & Transform sorcery, but that's not my field of expertise. Because it's an interesting problem and because I can think of use cases for my own projects, here's my take on it.
免责声明:此代码已被取消，尚未经过全面测试.使用风险自负.
Disclaimer: this code is hot off the stove and hasn't been thoroughly tested. Use at your own risk.
首先，创建一个新的工作簿，并在Sheet1上，从单元格A1开始设置这些值(我已添加SubCategory列用于测试):
First, create a new workbook and, on Sheet1, set these values starting at cell A1 (I've added the SubCategory column for testing purposes):
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的类模块，并将以下代码粘贴到其中:
Then, create a class module named CTextTransposer and paste this code into it:
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
最后，创建一个模块并将此代码粘贴到其中:
Finally, create a module and paste this code into it:
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开始的结果.查看测试代码，您将看到我使用了该类提供的所有选项，并且利用它返回的范围进行了一些基本格式化.
Run the TestTextTransposer sub and observe the results starting on Sheet1, cell H10. Looking at the test code, you'll see I've used all options offered by the class, plus I've made use of the ranges it returns to do some basic formatting.
我不会在这里解释所有详细信息，但是您会看到它可以归结为一些字典和一些数组操作.希望对您有所帮助.
I won't explain all of the details here, but you'll see it boils down to a few dictionaries and some array manipulations. Hope it helps.
注意:如前所述，以字符串为键的类的字典区分大小写，因此必须牢记这一点来准备源数据.可以通过在类中添加另一个属性来轻松地对其进行参数化.
Note: as posted, the classe's dictionaries keyed by strings are case-sensitive, so your source data has to be prepared with this in mind. This can easily parameterized by adding another property to the class.
这是最终结果(应用了更多格式):
Here's the end result (with a little more formatting applied):
这篇关于Excel 2013枢轴层次结构，非数值数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
