代码之家 › 专栏 › 技术社区 › jjjjjjjjjjj

Excel 2013 pivot分层非数字数据

excel-2013 excel vba

jjjjjjjjjjj · 技术社区 · 7 年前

我有这样的分层数据

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 看起来很有希望,但它只能透视单个非层次列。我怎样才能实现我的目标?

2 回复 | 直到 6 年前

jeffreyweir 6 年前

我在网上找不到代码来做你想做的事。通过一些Get&转换魔法,但那不是我的专业领域。因为这是一个有趣的问题,因为我可以为自己的项目想出用例,下面是我对它的看法。

免责声明 :此代码在炉外很热,尚未经过彻底测试。使用风险自负。

首先,创建一个新工作簿,在Sheet1上,从单元格A1开始设置这些值(为了测试目的,我添加了子类别列):

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 sub并从上开始观察结果 Sheet1 单间牢房 H10 . 看看测试代码,你会发现我已经使用了类提供的所有选项,另外我还使用了它返回的范围来进行一些基本的格式化。

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

笔记

以下是最终结果(应用了更多格式):

jeffreyweir 6 年前

从你的回答来看,你似乎想要这样:

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

...好处是这些G行没有重复。。。相反,你会得到一个计数。但除此之外,你从这两个方面都能得到完全相同的信息。您不想要“本机”数据透视表布局的具体原因是什么?