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 

我想把它转换成用户可读的格式。

我能够构build数据透视表，但是我想使用非数字数据作为枢纽。 这个答案中的VBA代码看起来很有前途，但它只能支持一个非分层的列。 我怎样才能达到我的目标？

Answer 1

我找不到在networking上的代码来做你正在寻找的东西。 这可能是通过一些获取和变换魔法，但这不是我的专业领域。 因为这是一个有趣的问题，因为我可以为自己的项目考虑用例，下面是我的看法。

免责声明 ：这个代码是热的炉子，并没有经过彻底的testing。 使用风险自负。

首先，创build一个新的工作簿，并在Sheet1上，从单元格A1开始设置这些值（为了testing目的，我添加了子类别列）：

 Country Region Category SubCategory ProgramName USA North SchoolName XA USA North SchoolName XB USA South SchoolName YC Brasil East SchoolName YD Brasil East CollegeName XE Brasil West CollegeName YF 

然后，创build一个名为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 

最后，创build一个模块并将其粘贴到其中：

 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开始的结果。 看看testing代码，你会看到我已经使用了该类提供的所有选项，另外我已经利用它返回的范围来做一些基本的格式化。

我不会在这里解释所有的细节，但你会看到它归结为几个字典和一些数组操作。 希望能帮助到你。

注意 ：发布时，类别string键入的类别字典区分大小写，因此必须准备好源数据。 这可以通过向该类添加另一个属性来轻松进行参数化。

这是最终的结果（应用更多的格式）：

Answer 2

所以从你的答案听起来像你想这样：

但数据透视表实际上给你一个更好的方式来查看原生的完全相同的信息，如下所示：

…奖金是没有重复的G行…而是你得到一个计数。 但除此之外，你从两者中得到完全相同的信息。 为什么你不希望“原生”数据透视表布局的任何特定原因？