Benutzerdefinierte Gruppierung von numerischen Werten Pivot mit VBA-Codes

Question

Ich habe eine Liste der Preise für die verkauften Produkte und die Preisänderungen von der letzten Woche, jetzt berechne ich Prozentsatzänderung und ich schreibe VBA-Codes, um eine Pivot-Tabelle einschließlich der Gruppierung zu erstellen der Prozentbereiche.

Mit der Hilfe von Kollegen, ich kann Bereiche von 10,0% jedoch muss ich die Codes auf die Prozentsätze unter 0,0% überarbeiten ist eine Gruppe (< 0,0%), mehr als 100,0% (> 100,0%) ist eine Gruppe, und zwischen ihnen, brauche ich Bereiche von 0,0% - 9,9% und 10,0% bis 19,9% und so weiter.

Ich habe die Codes leicht geändert, um meinen Bedürfnissen gerecht zu werden (Ersetze "zu" durch "-"), aber ich fügte nur 0% hinzu, so dass jetzt Bereiche wie 10.0% statt 10% angezeigt werden So gruppiere ich sie.

Option Explicit 

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

Set pt = ActiveSheet.PivotTables("% Premium Difference") '<= Change as appropriate 
Set pf = pt.PivotFields("% Premium Difference from Prior Term2") '<= 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 = " - ") 

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 & ".0%" 
     ElseIf InStr(.Caption, ">") > 0 Then 
      'Greater Than Group 
      .Caption = ">" & Split(.Caption, ">")(1) * 100 & ".0%" 
     Else 
      sCaption = "" 
      vSplit = Split(pi.Caption, "--") 
      If UBound(vSplit) = 1 Then 
       'Negative numbers 
       .Caption = vSplit(0) * 100 & ".0%" & sDelim & "-" & vSplit(1) * 100 & ".0%" 
      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) & ".0%" & sDelim & vSplit(1) & ".0%" 
       End If 
     End If 
    End With 
    sCaption = Replace$(sCaption, "to", sDelim) 
Next pi 

pf.Parent.ManualUpdate = False 

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

Answer 1

Ich habe geändert auch den Code es eine generische Routine zu machen, so dass Sie in dem Zahlenformat Sie wollen passieren kann. Sie können jetzt verschiedene untere und obere Grenzen angeben und einen optionalen Parameter namens dBreakPoint übergeben, der die Obergrenze jeder Gruppierung reduziert.

Sub PercentGroupings(pf As PivotField, _ 
       lFrom As Double, _ 
       lTo As Double, _ 
       lGroup As Double, _ 
       Optional vFormat As Variant, _ 
       Optional dBreakPoint As Double = 0, _ 
       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 

    If IsMissing(vFormat) Then vFormat = pf.NumberFormat 
    If vFormat = "General" Then vFormat = "" 


    'Format so that groupings appear as % values 
    For Each pi In pf.PivotItems 
     With pi 
      If InStr(.Caption, "<") > 0 Then 
       'Less Than Group 
       .Caption = "<" & Format(Split(.Caption, "<")(1), vFormat) 
      ElseIf InStr(.Caption, ">") > 0 Then 
       'Greater Than Group 
       .Caption = ">" & Format(Split(.Caption, ">")(1), vFormat) 
      Else 
       sCaption = "" 
       vSplit = Split(pi.Caption, "--") 
       If UBound(vSplit) = 1 Then 
        'Negative numbers 
        .Caption = Format(vSplit(0), vFormat) & sDelim & "-" & Format(vSplit(1) - dBreakPoint, vFormat) 
       Else 
        'Positive numbers 
        vSplit = Split(pi.Caption, "-") 
        Select Case UBound(vSplit) 
        Case 2 
         'Grouping spans zero 
         vSplit(0) = -vSplit(1) 
         vSplit(1) = vSplit(2) 
        Case 3 
         ' 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) 
          vSplit(1) = 0 
         End If 
        End Select 
        .Caption = Format(vSplit(0), vFormat) & sDelim & Format(vSplit(1) - dBreakPoint, vFormat) 
        End If 
      End If 
     End With 
     sCaption = Replace$(sCaption, "to", sDelim) 
    Next pi 

    pf.Parent.ManualUpdate = False 

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

Sie nennen es wie folgt aus:

Sub FormatPivotGroups() 

Dim pf As PivotField 

Set pf = ActiveSheet.PivotTables("PivotTable3").PivotFields("Price Difference") '<= Change as appropriate 
PercentGroupings pf, -1, 1, 0.1, "0%" 
End Sub 

..., die dieses Ergebnis hat:

Wenn Sie den oberen Bereich festlegen möchten, so dass es weniger als der untere Bereich der nächsten möglichen Gruppierung verwenden Sie etwas wie folgt:

PercentGroupings pf, -1, 1, 0.1, "0%", 0.001 

..., die diesen Effekt hat:

Wenn Sie unter 0 zu gruppieren etwas wollten, man muss nur aus ein, dass die ersten Argumente ändern -1 auf ein 0:

PercentGroupings pf, 0, 1, 0.1, "0%", 0.001 

..., die dieses Ergebnis hat:

Und wenn Sie einen Bindestrich (oder irgendetwas anderes) als Trennzeichen anstelle des Standard-Wort „zu“ dann würden Sie es so nennen nutzen wollte:

PercentGroupings pf, 0, 1, 0.1, "0%", 0.001, " - " 

..., die diese Wirkung haben würde:

können Sie das Format auch angewendet ändern. Also, wenn Sie diese Zahlen zeigen, wie US-Dollar und in Bands wollten die 99 Cent breit waren, dann würden Sie es so nennen:

PercentGroupings pf, 0, 1, 0.1, "$0.00", 0.01, " - " 

...was hat dieses Ergebnis: