Question

我有像这样的分层数据

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似乎很有希望，但它只能转动一个非分层列。我怎样才能实现目标？

Answer 1

我无法在网上找到代码来做你正在寻找的东西。有可能通过一些Get＆amp;改变巫术，但这不是我的专业领域。因为这是一个有趣的问题，因为我可以为我自己的项目考虑用例，这是我对它的看法。

免责声明：此代码在炉子上很热，尚未经过彻底测试。使用风险自负。

首先，创建一个新工作簿，然后在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开始观察结果。查看测试代码，您将看到我已经使用了该类提供的所有选项，而且我已经使用它返回的范围来进行一些基本的格式化。

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

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

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

Answer 2

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

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

...奖励是没有重复那些G行...而是你得到了一个计数。但除此之外，您可以从中获得完全相同的信息。你不想要'原生'数据透视表布局的任何特殊原因？

Excel 2013透视分层，非数字数据

2 个答案: