使用button向上/向下钻取
我正在尝试创build一些命令button，允许用户在Power-pivot层次结构中向下钻取。 我已经能够生成代码，当我在工作表上引用一个特定的行时，我已经无法调整它来根据用户select的行/单元向下钻取/ 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
提前感谢您的帮助！
在花了一些时间，并从一些朋友那里得到一些想法之后，我能够编写允许您创build自定义button的代码，这些自定义button将向下钻取，钻取并钻取到枢纽层次结构的顶部。
我绝不是VBA方面的专家，我很乐意提出改进方法的build议。 我发现这个代码对于我制作的产品是非常有用的，所以我想我会分享一些回馈社区的东西。
我devise的代码要尽可能简单，并且能够以最小的修改来重用代码。 因此，我使用“Lvl”的命名前缀，并编号1-4级（但我编码，以便您可以指定自己的自定义前缀）。 假定您可以在实际数据透视表中重命名字段而不影响后端，则层次结构前缀不会导致任何自定义问题。
最后说明：有几个部分需要用户input您的前缀，表名等，并标有“用户input需要”。 此外，这是使用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