Question

我列出了所售产品的价格和上周的价格变化，现在我正在计算百分比变化，我正在编写vba代码来创建包含百分比范围分组的数据透视表。

需要有关分组的帮助。

    Sub Part_I()


'Group by
Dim pf3 As PivotField

Pvt2.RowAxisLayout xlTabularRow
Set pf3 = Pvt2.PivotFields("% Premium Difference from Prior Term")
pf3.LabelRange.Group Start:=-1, End:=1.2, By:=0.1
pf3.Caption = "% Premium Difference from Prior Term2"



Dim pi3          As PivotItem
Dim sCaption3    As String

Application.ScreenUpdating = False


'Format so that groupings appear as percentage values


For Each pi4 In pf3.PivotItems

    sCaption3 = pi3.Caption & "0.0%"
    sCaption3 = Replace$(sCaption3, "0.", "")
    sCaption3 = Replace$(sCaption3, "-", " - ")
    sCaption3 = Replace$(sCaption, "0%", "0.0%")
    sCaption3 = Replace$(sCaption3, " - ", "0.0% - ")
    sCaption3 = Replace$(sCaption3, "00.0%", "0.0%")
    sCaption3 = Replace$(sCaption3, "<0.0%", "<")
    sCaption3 = Replace$(sCaption3, "< - 10.0%", "-100.0% - 0.0%")
    pi3.Caption = sCaption3

Next pi4

Application.ScreenUpdating = True

Answer 1

好的，我已经组成了一个名为PercentGroupings的paramatised子，您可以从主程序调用，如下所示：

    Option Explicit

Sub GroupPercents()
Dim pt As PivotTable
Dim pf As PivotField

Set pt = ActiveSheet.PivotTables("PivotTable1") '<= Change as appropriate
Set pf = pt.PivotFields("Data") '<= Change as appropriate
PercentGroupings pf, -1, 1, 0.1
End Sub

Sub PercentGroupings(pf As PivotField, lFrom As Double, lTo As Double, lGroup As Double, Optional sDelim As String = " to ")

Dim pi          As PivotItem
Dim sCaption    As String
Dim vSplit      As Variant
Dim vItem       As Variant
Dim i           As Long


With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With


On Error Resume Next
pf.LabelRange.Ungroup
On Error GoTo 0

pf.LabelRange.Group Start:=lFrom, End:=lTo, By:=lGroup
pf.Parent.ManualUpdate = True


'Format so that groupings appear as % values
For Each pi In pf.PivotItems
    With pi
        If InStr(.Caption, "<") > 0 Then
            'Less Than Group
            .Caption = "<" & Split(.Caption, "<")(1) * 100 & "%"
        ElseIf InStr(.Caption, ">") > 0 Then
            'Greater Than Group
            .Caption = ">" & Split(.Caption, ">")(1) * 100 & "%"
        Else
            sCaption = ""
            vSplit = Split(pi.Caption, "--")
            If UBound(vSplit) = 1 Then
                'Negative numbers
                .Caption = vSplit(0) * 100 & "%" & sDelim & "-" & vSplit(1) * 100 & "%"
            Else
                'Positive numbers
                vSplit = Split(pi.Caption, "-")
                If UBound(vSplit) = 1 Then
                    On Error Resume Next
                    vSplit(0) = vSplit(0) * 100
                    vSplit(1) = vSplit(1) * 100
                    On Error GoTo 0
                ElseIf UBound(vSplit) = 3 Then
                    ' There's some kind of bug with Excel's Grouping feature whereby
                    ' the zero grouping sometimes shows as scientific notation  e.g. -2.77555756156289E-17
                    ' So we'll test for this, and change it to zero
                    If IsNumeric(Join(Array(vSplit(2), vSplit(3)), "-")) Then
                        vSplit(0) = vSplit(1) * -100
                        vSplit(1) = 0
                    End If
                End If
                .Caption = vSplit(0) & "%" & sDelim & vSplit(1) & "%"
            End If
        End If
    End With
Next pi

pf.Parent.ManualUpdate = False

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

...这会给你这个：

使用vba的数据透视表分组百分比范围

1 个答案: