使用按钮钻取 Up/Down
Drill Up/Down using buttons
我正在尝试创建一些命令按钮，允许用户在 Power-pivot 层次结构中向下和向上钻取。当我引用 sheet 上的特定行时，我已经能够生成向下钻取的代码，但我无法调整它以根据 line/cell 用户钻取 down/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
提前感谢您的帮助！
在为此投入了一些时间并从一些朋友那里得到了一些想法之后，我能够编写代码，允许您创建自定义按钮，这些按钮将向下钻取、向上钻取和钻取到数据透视层次结构的顶部。
我绝不是 VBA 方面的专家，并且乐于接受有关改进方法的建议。我发现这段代码对我正在制作的产品非常有用，所以我想我会分享一些东西来回馈社区。
我将代码设计得尽可能简单，并且能够以最少的修改重用代码；因此我使用 "Lvl" 的命名前缀并将级别编号为 1-4（但是我对其进行了编码，以便您也可以指定自己的自定义前缀）。
鉴于您能够在不影响后端的情况下重命名实际数据透视表 table 中的字段，层次结构前缀不会导致任何自定义问题。
最后注意：有几个部分需要用户输入您的前缀、table 名称等，并标有 "User entry needed"。此外，这是使用 AdventureWorks SQL 示例数据库开发的（excel 通过电源查询连接到 SQL 并将数据拉入 Excel 数据模型）。
如果您有任何问题，请随时提出，希望对您有所帮助！
Sub DrillDown()
On Error GoTo ErrorHandler
'This code was developed by Whosebug user CITYINBETWEEN and was posted on the Whosebug
'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 Whosebug user CITYINBETWEEN and was posted on the Whosebug
'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 Whosebug user CITYINBETWEEN and was posted on the Whosebug
'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
我正在尝试创建一些命令按钮，允许用户在 Power-pivot 层次结构中向下和向上钻取。当我引用 sheet 上的特定行时，我已经能够生成向下钻取的代码，但我无法调整它以根据 line/cell 用户钻取 down/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
提前感谢您的帮助！
在为此投入了一些时间并从一些朋友那里得到了一些想法之后，我能够编写代码，允许您创建自定义按钮，这些按钮将向下钻取、向上钻取和钻取到数据透视层次结构的顶部。
我绝不是 VBA 方面的专家，并且乐于接受有关改进方法的建议。我发现这段代码对我正在制作的产品非常有用，所以我想我会分享一些东西来回馈社区。
我将代码设计得尽可能简单，并且能够以最少的修改重用代码；因此我使用 "Lvl" 的命名前缀并将级别编号为 1-4（但是我对其进行了编码，以便您也可以指定自己的自定义前缀）。 鉴于您能够在不影响后端的情况下重命名实际数据透视表 table 中的字段，层次结构前缀不会导致任何自定义问题。
最后注意：有几个部分需要用户输入您的前缀、table 名称等，并标有 "User entry needed"。此外，这是使用 AdventureWorks SQL 示例数据库开发的（excel 通过电源查询连接到 SQL 并将数据拉入 Excel 数据模型）。
如果您有任何问题，请随时提出，希望对您有所帮助！
Sub DrillDown()
On Error GoTo ErrorHandler
'This code was developed by Whosebug user CITYINBETWEEN and was posted on the Whosebug
'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 Whosebug user CITYINBETWEEN and was posted on the Whosebug
'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 Whosebug user CITYINBETWEEN and was posted on the Whosebug
'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