使用按钮钻取/向下钻取

Question

我正在尝试创建一些命令按钮，允许用户在Power-pivot层次结构中向下钻取。我已经能够生成代码，当我在表单上引用特定行时，我已经无法将其调整为根据用户选择的行/单元细分/ p。

是否可以将.PivotRowAxis.PivotLines(1)更改为.ActiveCell之类的东西？

我全码：

Sub DrillDown() 
On Error GoTo ErrorHandler 

    ActiveSheet.PivotTables("PivotTable1").DrillDown ActiveSheet.PivotTables(_ 
     "PivotTable1").PivotFields("[Data].[Dive1].[ASSIGNEDTO]").PivotItems(_ 
     "[Data].[Dive1].[ASSIGNEDTO].&[Adjustment, MyDB]"), ActiveSheet.PivotTables(_ 
     "PivotTable1").PivotRowAxis.PivotLines(1) 
    Exit Sub 

ErrorHandler: 
    Dim Msg, Style, Title, Notify 
    Msg = "Unable to Drill Down any further" 
    Style = vbError 
    Title = "Drll Down Error" 
    Notify = MsgBox(Msg, Style, Title) 


End Sub 

Sub DrillUp() 
On Error GoTo ErrorHandler 

    ActiveSheet.PivotTables("PivotTable1").DrillUp ActiveSheet.PivotTables(_ 
     "PivotTable1").PivotFields("[Data].[Dive1].[ClientID]").PivotItems(_ 
     "[Data].[Dive1].[ASSIGNEDTO].&[Adjustment, MYDB].&[QMMX123]"), _ 
     ActiveCell.Select 
    Exit Sub 

ErrorHandler: 
    Dim Msg, Style, Title, Notify 
    Msg = "Unable to Up any further" 
    Style = vbError 
    Title = "Drill Up Error" 
    Notify = MsgBox(Msg, Style, Title) 


End Sub 

感谢您的帮助提前！

Answer 1

在投入了一些时间并从一些朋友那里得到一些想法之后，我能够编写代码，允许您创建自定义按钮，将向下钻取，钻取并钻取到您的透视层次结构顶部。

我绝不是VBA的专家，并且对如何改善这一点提出建议。我发现这个代码对于我制作的产品非常有用，所以我想我会分享一些回馈社区的东西。

我设计的代码要尽可能简单，并且能够通过最少的修改重新使用代码;因此我使用了“Lvl”的命名前缀并且编号为1-4级（但是我编码它以便您可以指定您自己的自定义前缀）。 鉴于您可以在实际透视表中重命名您的字段而不影响后端，层次结构前缀不会导致任何自定义问题。

最后说明：有几个部分需要用户输入您的前缀，表名等，并标有“需要用户输入”。此外，这是使用AdventureWorks SQL示例数据库（Excel通过电源查询连接到SQL并将数据拉入Excel数据模型）开发的。

请随时问，如果您有任何问题，我希望这可以帮助！

Sub DrillDown() 
On Error GoTo ErrorHandler 
'This code was developed by stackoverflow user CITYINBETWEEN and was posted on the stackoverflow 
'forums for everyone to use free of charge and is not to be sold to others. 
' 
' Drill Down Macro 
' 
    Dim HrchyPreFix, HrchyLstLvl, MyCurrLocation, MyPivTblName, MyDrillTo 
    '---------- User Entry Needed ----------' 
    ' prefix used for hierarchy levels 
    HrchyPreFix = "Lvl" 
    ' set hierarchy last drill down level 
    HrchyLstLvl = "4" 
    '---------- End of User Entry ----------' 

    ' set pivot table name of active cell 
    MyPivTblName = ActiveCell.PivotTable 
    ' set pivot field selected of active cell 
    MyCurrLocation = ActiveCell.PivotCell.PivotField 
    ' set what hierarchy lvl to drill down to 
    MyDrillTo = ActiveCell.PivotCell.PivotItem 

    ' find current hierarchy lvl of active cell. if at the last lvl, if statement goes to BottomOfDrillDownHandler 
    HrchyCurrLvl = (Right(Left(Mid(ActiveCell.PivotField, InStr(1, ActiveCell.PivotField, HrchyPreFix)), 4), 1)) 
    ' If at last hierarchy lvl, go to BottomOfDrillDownHandler 
    If HrchyCurrLvl = HrchyLstLvl Then 
     GoTo BottomOfDrillDownHandler 
    End If 

    ' drill down code 
    ActiveSheet.PivotTables(MyPivTblName).DrillDown ActiveSheet.PivotTables(_ 
     MyPivTblName).PivotFields(MyCurrLocation).PivotItems(MyDrillTo), _ 
     ActiveSheet.PivotTables(MyPivTblName).PivotRowAxis.PivotLines(1) 
    Exit Sub 

' Error handler for when you cannot drill down any further 
BottomOfDrillDownHandler: 
    Dim ErrMsg1, ErrTitle1 
    ErrMsg1 = "Unable to Drill Down any further as you're at the bottom of the Drill Down" 
    ErrTitle1 = "Drill Down Error" 
    MsgBox ErrMsg1, , ErrTitle1 
    Exit Sub 

' general error handler 
ErrorHandler: 
    Dim ErrMsg2, ErrTitle2, ErrMsg3, ErrTitle3 
    If Err.Number = 1004 Then 
     ErrMsg2 = "Please select a drillable item" 
     ErrTitle2 = "Drill Down Error" 
     MsgBox ErrMsg2, , ErrTitle2 
    ElseIf Err.Number <> 0 Then 
     ErrMsg3 = "Error # " & Str(Err.Number) & " was generated by " _ 
      & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description 
     ErrTitle3 = "Error" 
    MsgBox ErrMsg3, , ErrTitle3, Err.HelpFile, Err.HelpContext 
    End If 
End Sub 

'-------------------------------------------------------------------- 
Sub DrillUp() 
On Error GoTo ErrorHandler 
'This code was developed by stackoverflow user CITYINBETWEEN and was posted on the stackoverflow 
'forums for everyone to use free of charge and is not to be sold to others. 
' 
' Drill Up 1 level Macro 
' 
    Dim PwrPivTblNm, HrchyNm, HrchyPreFix, HrchyTopLvl, MyCurrLocation, MyPivTblName, MyDrillTo, MyCurrLvl, HrchyPrevLvl As Integer 

    '---------- User Entry Needed ----------' 
    ' Name of table in powerpivot where the hierarchy exists 
    PwrPivTblNm = "vEmployeeDepartment" 
    ' name given to hierarchy in powerpivot 
    HrchyNm = "Hierarchy1" 
    ' prefix used for hierarchy levels 
    HrchyPreFix = "Lvl" 
    ' set top hierarchy level 
    HrchyTopLvl = "1" 
    '---------- End of User Entry ----------' 

    ' set pivot table name of active cell 
    MyPivTblName = ActiveCell.PivotTable 
    ' set pivot field selected of active cell 
    MyCurrLocation = ActiveCell.PivotCell.PivotField 
    ' set from what hierarchy lvl to drill up from 
    MyDrillUpFrom = ActiveCell.PivotCell.PivotItem 
    ' find prev. hierarchy lvl of active cell 
    HrchyPrevLvl = (Right(Left(Mid(ActiveCell.PivotField, InStr(1, ActiveCell.PivotField, HrchyPreFix)), 4), 1) - 1) 

    ' find current hierarchy lvl of active cell. if at the top lvl, if statement goes to TopOfDrillUpHandler 
    HrchyCurrLvl = (Right(Left(Mid(ActiveCell.PivotField, InStr(1, ActiveCell.PivotField, HrchyPreFix)), 4), 1)) 
    ' If at last hierarchy lvl, go to TopOfDrillUpHandler 
    If HrchyCurrLvl = HrchyTopLvl Then 
     GoTo TopOfDrillUpHandler 
    End If 

    ' set hierarchy level to drill up to 
    HrchyLvlDrillTo = "[" & PwrPivTblNm & "].[" & HrchyNm & "].[" & _ 
        Mid(ActiveCell.PivotField, InStr(1, ActiveCell.PivotField, HrchyPreFix), 3) & HrchyPrevLvl _ 
        & "]" 

    ' drill up code 
    ActiveSheet.PivotTables(MyPivTblName).DrillUp ActiveSheet.PivotTables(_ 
     MyPivTblName).PivotFields(MyCurrLocation).PivotItems(MyDrillUpFrom), _ 
     ActiveSheet.PivotTables(MyPivTblName).PivotRowAxis.PivotLines(1), HrchyLvlDrillTo 
    Exit Sub 

' Error handler for when you cannot drill up any further 
TopOfDrillUpHandler: 
    Dim ErrMsg1, ErrTitle1 
    ErrMsg1 = "Unable to Drill Up any further as you're at the top of the Drill Up" 
    ErrTitle1 = "Drill Up Error" 
    MsgBox ErrMsg1, , ErrTitle1 
    Exit Sub 

' General Error handler 
ErrorHandler: 
    Dim ErrMsg2, ErrTitle2, ErrMsg3, ErrTitle3 
    If Err.Number = 1004 Then 
     ErrMsg2 = "Please select a drillable item" 
     ErrTitle2 = "Drill Up Error" 
     MsgBox ErrMsg2, , ErrTitle2 
    ElseIf Err.Number <> 0 Then 
     ErrMsg3 = "Error # " & Str(Err.Number) & " was generated by " _ 
      & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description 
     ErrTitle3 = "Error" 
    MsgBox ErrMsg3, , ErrTitle3, Err.HelpFile, Err.HelpContext 
    End If 
End Sub 


'-------------------------------------------------------------------- 
Sub DrillToTop() 
On Error GoTo ErrorHandler 
'This code was developed by stackoverflow user CITYINBETWEEN and was posted on the stackoverflow 
'forums for everyone to use free of charge and is not to be sold to others. 
' 
' Dill To Top Macro Macro 
' 
    Dim PwrPivTblNm, HrchyNm, HrchyPreFix, HrchyTopLvl, MyCurrLocation, MyPivTblName, MyDrillTo 

    '---------- User Entry Needed ----------' 
    ' Name of table in powerpivot where the hierarchy exists 
    PwrPivTblNm = "vEmployeeDepartment" 
    ' name given to hierarchy in powerpivot 
    HrchyNm = "Hierarchy1" 
    ' prefix used for hierarchy levels 
    HrchyPreFix = "Lvl" 
    ' set top hierarchy level 
    HrchyTopLvl = "1" 
    '---------- End of User Entry ----------' 

    ' set pivot table name of active cell 
    MyPivTblName = ActiveCell.PivotTable 
    ' set pivot field selected of active cell 
    MyCurrLocation = ActiveCell.PivotCell.PivotField 
    ' set from what hierarchy lvl to drill up from 
    MyDrillUpFrom = ActiveCell.PivotCell.PivotItem 

    ' find prev. hierarchy lvl of active cell. if already at top lvl, if statement goes to AlreadyAtTopHandler 
    HrchyPrevLvl = (Right(Left(Mid(ActiveCell.PivotField, InStr(1, ActiveCell.PivotField, "Lvl")), 4), 1) - 1) 
    ' If at hierarchy lvl 1, go to TopOfDrillUpHandler 
    If HrchyPrevLvl = "0" Then 
     GoTo AlreadyAtTopHandler 
    End If 

    ' set top hierarchy level to drill up to 
    HrchyLvlDrillTo = "[" & PwrPivTblNm & "].[" & HrchyNm & "].[" & _ 
        Mid(ActiveCell.PivotField, InStr(1, ActiveCell.PivotField, HrchyPreFix), 3) & HrchyTopLvl _ 
        & "]" 

    ' drill to top code 
    ActiveSheet.PivotTables(MyPivTblName).DrillUp ActiveSheet.PivotTables(_ 
     MyPivTblName).PivotFields(MyCurrLocation).PivotItems(MyDrillUpFrom), _ 
     ActiveSheet.PivotTables(MyPivTblName).PivotRowAxis.PivotLines(1), _ 
     HrchyLvlDrillTo 
    Exit Sub 

' Error handler for when user is already at the top level 
AlreadyAtTopHandler: 
    Dim ErrMsg1, ErrTitle1 
    ErrMsg1 = "Unable to Drill to Top as you're already at the top level" 
    ErrTitle1 = "Drill to Top Error" 
    MsgBox ErrMsg1, , ErrTitle1 
    Exit Sub 

' General Error handler 
ErrorHandler: 
    Dim ErrMsg2, ErrTitle2, ErrMsg3, ErrTitle3 
    If Err.Number = 1004 Then 
     ErrMsg2 = "Please select a drillable item" 
     ErrTitle2 = "Drill to Top Error" 
     MsgBox ErrMsg2, , ErrTitle2 
    ElseIf Err.Number <> 0 Then 
     ErrMsg3 = "Error # " & Str(Err.Number) & " was generated by " _ 
      & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description 
     ErrTitle3 = "Error" 
    MsgBox ErrMsg3, , ErrTitle3, Err.HelpFile, Err.HelpContext 
    End If 
End Sub