Excel 2013 透视分层非数字数据答案

【问题标题】：Excel 2013 pivot hierarchical, nonnumerical dataExcel 2013 透视分层非数字数据
【发布时间】：2017-11-10 21:33:07
【问题描述】：

我有这样的分层数据

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

我想将其转换为用户可读的格式。

我能够构建数据透视表，但是我想使用非数字数据作为数据透视表。 The VBA code in this answer 看起来很有希望，但它只能旋转一个非分层列。我怎样才能实现我的目标？

【问题讨论】：

您可以添加一个将字母转换为数字的数据列，例如1..6 在您的情况下，在此列上进行数据透视，复制/粘贴数据透视表的内容并替换回字母。
@Excelosaurus 该列表总是在变化，所以很遗憾我无法创建数字参考表。如果一个地区和国家有多个SchoolName，则该数字将被汇总。
我很困惑：你说这个数字是聚合的。几号？
Argh，错过了“串联”A 和 B。@jeffrey，OP 正在响应我的（不可用的）建议。
如果我理解正确，“数据”实际上并不是数据。这是一个属性。所以给它另一个名字（我将在这里使用“程序”）并添加一个名为“数据”的新列，并在其中为每一行添加一个 1。然后将该数字数据字段放入数据透视表数据区域，并将程序字段放入行区域。然后你可以使用数字格式让 Values 区域中的 1 值看起来像刻度线什么的。

标签： vba excel excel-2013

【解决方案1】：

我在网上找不到代码来做你正在寻找的事情。通过一些 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 的类模块并将此代码粘贴到其中：

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。查看测试代码，您会发现我已经使用了该类提供的所有选项，此外我还利用它返回的范围来进行一些基本的格式化。

我不会在这里解释所有细节，但您会发现它归结为一些字典和一些数组操作。希望对您有所帮助。

注意：正如发布的那样，由字符串键入的类字典区分大小写，因此您的源数据必须牢记这一点。这可以通过向类中添加另一个属性来轻松参数化。

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

【讨论】：

我自己仍然会使用数据透视表运行，但这真的很酷！期待从您的代码中学习。
感谢您的编辑。您只会了解不良的匈牙利符号习惯 ;-)
我将测试数据复制到 Sheet1 中的单元格 A1。我得到Unable to get the Match property of the WorksheetFunction class 并将其缩小到GetHeaderColumnIndex = Application.WorksheetFunction.Match(psColumnHeader, m_rngSource.Rows(1), 0)。不知道是什么原因。
我从 Visual Basic 窗口运行宏。这会是一个原因吗？
当然可以。将 Sheet1 替换为包含您的数据的工作表代号。从 VB 编辑器中可以看到工作表的 CodeName 是其 (Name) 属性（单击 Project Explorer 中的工作表；您可以将 (Name) 更改为您认为合适的任何内容）。或者您可以使用ThisWorkbook.Worksheets("YourSheetName")，但这会将您的代码与 Excel 中工作表的选项卡名称联系起来，这是不可取的。

【解决方案2】：

所以从你的回答听起来你想要这个：

但数据透视表实际上为您提供了一种更好的方式来本地查看完全相同的信息，如下所示：

...额外的好处是那些 G 行没有重复...相反你得到了一个计数。但除此之外，您可以从其中任何一方获得完全相同的信息。您不想要“本机”数据透视表布局的任何特殊原因？

【讨论】：

不完全。我想用文字代替数字。每个国家、地区和类别可以有多个 ProgramName。
关于“在国家、地区和类别之前可以有多个 ProgramName”：上述 Pivot 将处理该问题。假设您还有两个名为 G 的 ProgramName，分别代表“CollegeName”、“Brasil”和“North”。当您将它添加到您的数据并刷新 Pivot 时，您会得到一个新行显示它，计数为 2。这不是您想要显示的内容吗？
当然，您可以通过某种方式将每个数字替换为一个字母，而不是“CollegeName”、“Brasil”和“North”一行，您可以使用两行F 显示在数值区域中。但这最终并不代表您数据的任何不同“维度”，而不是上面显示的。
本机布局用于传达信息，但此图表将呈现给其他人。如果可能的话，我想避免强迫人们来回查看名称。
两个词：冻结窗格。