This Add-In for Excel was developed by me for free use, without any warranty!
Functions: Test Hierarchy data of the BPC Dimension before processing Dimension.
Usage: Install Add-In, on the Add-Ins Ribbon you will see one button for this Add-In.
When you have Dimension template opened (in BPC Client or as a standalone file) - press this button.
All Hierarchies will be tested and the resulted TreeView will be presented. In case of error the message will describe the error, the TreeView form will not be shown and the cell with error will be selected.
Enforced rule: Non base members of one Hierarchy cannot have parent in another Hierarchy! (It's not mandatory in BPC but to my mind, linking nodes of one Hierarchy to parents in another Hierarchy will make the dimension unmanageable)
Additional feature: when you see a form with TreeView there is a combobox in the left down corner of the form. This combobox is populated with the list of member properties. If you select some property it will be shown in the TreeView right to each member.
Number of members is limited to 10 000, but it can be changed in the code.
How to create the Add-In:
In the new Excel file open VBA editor and go to References:
Create a new user form: frmTree with the following controls:
trvTest (TreeView4)
cmbProp (ComboBox)
btnClose (CommandButton) - Caption: Close
Insert code in the Code window of this user form:
' This Add-In for Excel was developed by Vadim Kalinin for free use, without any warranty!
' Functions: Test Hierarchy data of the BPC Dimension before processing Dimension
' Usage: Install Add-In, on the Add-Ins Ribbon you will see one button for this Add-In
' When you have Dimension template opened (in BPC Client or as standalone file) - press this button
' All Hierarchies will be tested and the resulted TreeView will be presented
' Enforced rule: non base members of one Hierarchy cannot have parent in another Hierarchy!
Option Explicit
Private wshActiveSheet As Worksheet
Private dctProp As Scripting.Dictionary
Private lngHIRCount As Long
Private strHIRArr() As String
Private lngRowsCount As Long
Private blnUnload As Boolean
Private strPropArr() As String
Private Const lngMaxColumns As Long = 256
Private Const lngMaxRows As Long = 10000
Private Sub btnClose_Click()
Unload Me
End Sub
Private Sub cmbProp_Change()
Dim lngTemp As Long
For lngTemp = 1 To lngRowsCount
strPropArr(lngTemp) = Trim(CStr(wshActiveSheet.Cells(lngTemp + 1, CLng(dctProp(Me.cmbProp.Value))).Value))
Next lngTemp
Me.trvTest.Nodes.Clear
FillTree
Me.trvTest.SetFocus
End Sub
Private Sub UserForm_Activate()
If blnUnload Then
Unload Me
End If
End Sub
Private Sub UserForm_Initialize()
Dim wbkTemp As Workbook
Dim lngTemp As Long
Dim lngTemp1 As Long
Dim lngTemp2 As Long
Dim lngTemp3 As Long
Dim lngTemp4 As Long
Dim lngColNumArr() As Long
Dim varPropArr() As Variant
Dim strTemp As String
Dim dctMembers As Scripting.Dictionary
Dim dctHIRArr() As Scripting.Dictionary
Dim dctNotBaseMembers As Scripting.Dictionary
blnUnload = False
On Error GoTo INBPC
Set wshActiveSheet = Application.ActiveWorkbook.ActiveSheet
GoTo NOTINBPC
INBPC:
If Err.Number = 91 Then
For Each wbkTemp In Application.Workbooks
If wbkTemp.Name = "Worksheet in BpcFramerControl" And wbkTemp.Path = "" Then
Set wshActiveSheet = wbkTemp.ActiveSheet
Set wbkTemp = Nothing
GoTo NOTINBPC
End If
Next wbkTemp
End If
MsgBox "ERROR: Unknown error happened!", , "Error!"
blnUnload = True
Exit Sub
NOTINBPC:
On Error GoTo 0
ReDim lngColNumArr(1 To lngMaxColumns)
Set dctProp = New Scripting.Dictionary
dctProp.CompareMode = BinaryCompare
lngTemp1 = 1
For lngTemp = 1 To lngMaxColumns
strTemp = Trim(CStr(wshActiveSheet.Cells(1, lngTemp).Value))
Select Case strTemp
Case "ID"
lngColNumArr(1) = lngTemp
Case "EVDESCRIPTION"
lngColNumArr(2) = lngTemp
Case ""
Exit For
Case Else
If Left(strTemp, 7) = "PARENTH" Then
lngColNumArr(CLng(Mid(strTemp, 8)) + 2) = lngTemp
lngTemp1 = lngTemp1 + 1
Else
dctProp.Add strTemp, lngTemp
End If
End Select
Next lngTemp
If lngColNumArr(1) = 0 Then
MsgBox "ERROR: ID column not found!", , "Error!"
ReDim lngColNumArr(1 To 1)
Set dctProp = Nothing
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
If lngColNumArr(2) = 0 Then
MsgBox "ERROR: Description column not found!", , "Error!"
ReDim lngColNumArr(1 To 1)
Set dctProp = Nothing
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
If lngColNumArr(3) = 0 Then
MsgBox "ERROR: PARENTH1 column not found!", , "Error!"
ReDim lngColNumArr(1 To 1)
Set dctProp = Nothing
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
lngHIRCount = lngTemp1 - 1
ReDim Preserve lngColNumArr(1 To lngHIRCount + 2)
varPropArr = dctProp.Keys
For lngTemp = 0 To dctProp.Count - 1
Me.cmbProp.AddItem CStr(varPropArr(lngTemp))
Next lngTemp
ReDim strHIRArr(1 To lngHIRCount + 2, 1 To lngMaxRows)
Set dctMembers = New Scripting.Dictionary
dctMembers.CompareMode = BinaryCompare
ReDim dctHIRArr(1 To lngHIRCount)
For lngTemp = 1 To lngHIRCount
Set dctHIRArr(lngTemp) = New Scripting.Dictionary
dctHIRArr(lngTemp).CompareMode = BinaryCompare
Next lngTemp
For lngTemp = 1 To lngMaxRows
For lngTemp1 = 1 To lngHIRCount + 2
strTemp = Trim(wshActiveSheet.Cells(lngTemp + 1, lngColNumArr(lngTemp1)).Value)
If strTemp = "" And lngTemp1 = 1 Then
GoTo ExitLoop
End If
strHIRArr(lngTemp1, lngTemp) = strTemp
Select Case lngTemp1
Case 1
dctMembers.Add strTemp, lngTemp
Case 2
If strTemp = "" Then
wshActiveSheet.Cells(lngTemp + 1, lngColNumArr(lngTemp1)).Select
MsgBox "ERROR: Member " & _
strHIRArr(lngTemp1 - 1, lngTemp) & " on the row: " & CStr(lngTemp + 1) & _
" has no description!", , "Error!"
ReDim strHIRArr(1 To 1, 1 To 1)
Set dctMembers = Nothing
Set dctProp = Nothing
For lngTemp3 = 1 To lngHIRCount
Set dctHIRArr(lngTemp3) = Nothing
Next lngTemp3
ReDim dctHIRArr(1 To 1)
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
Case Else
If (Not dctHIRArr(lngTemp1 - 2).Exists(strTemp)) And strTemp <> "" Then
dctHIRArr(lngTemp1 - 2).Add strTemp, lngTemp
End If
End Select
Next lngTemp1
Next lngTemp
ExitLoop:
lngRowsCount = lngTemp - 1
If lngRowsCount = 0 Then
MsgBox "ERROR: No members in dimension!", , "Error!"
ReDim strHIRArr(1 To 1, 1 To 1)
Set dctMembers = Nothing
Set dctProp = Nothing
For lngTemp3 = 1 To lngHIRCount
Set dctHIRArr(lngTemp3) = Nothing
Next lngTemp3
ReDim dctHIRArr(1 To 1)
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
ReDim Preserve strHIRArr(1 To lngHIRCount + 2, 1 To lngRowsCount)
'Test for HIR to be present in MEMBERS
For lngTemp = 1 To lngRowsCount
For lngTemp1 = 3 To lngHIRCount + 2
If strHIRArr(lngTemp1, lngTemp) <> "" Then
If Not dctMembers.Exists(strHIRArr(lngTemp1, lngTemp)) Then
wshActiveSheet.Cells(lngTemp + 1, lngColNumArr(lngTemp1)).Select
MsgBox "ERROR: Hierarchy PARENTH" & CStr(lngTemp1 - 2) & " member " & _
strHIRArr(lngTemp1, lngTemp) & " on the row: " & CStr(lngTemp + 1) & _
" is not present in Members!", , "Error!"
ReDim strHIRArr(1 To 1, 1 To 1)
Set dctMembers = Nothing
Set dctProp = Nothing
For lngTemp3 = 1 To lngHIRCount
Set dctHIRArr(lngTemp3) = Nothing
Next lngTemp3
ReDim dctHIRArr(1 To 1)
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
End If
Next lngTemp1
Next lngTemp
Set dctMembers = Nothing
'Test for HIR not to be present in other HIR
For lngTemp = 1 To lngRowsCount
For lngTemp1 = 3 To lngHIRCount + 2
For lngTemp2 = lngTemp1 + 1 To lngHIRCount + 2
If strHIRArr(lngTemp2, lngTemp) <> "" Then
If dctHIRArr(lngTemp1 - 2).Exists(strHIRArr(lngTemp2, lngTemp)) Then
wshActiveSheet.Cells(lngTemp + 1, lngColNumArr(lngTemp2)).Select
MsgBox "ERROR: Hierarchy PARENTH" & CStr(lngTemp2 - 2) & " member " & _
strHIRArr(lngTemp2, lngTemp) & " on the row: " & CStr(lngTemp + 1) & _
" is present in hierarchy PARENTH" & CStr(lngTemp1 - 2) & "!", , "Error!"
ReDim strHIRArr(1 To 1, 1 To 1)
Set dctProp = Nothing
For lngTemp3 = 1 To lngHIRCount
Set dctHIRArr(lngTemp3) = Nothing
Next lngTemp3
ReDim dctHIRArr(1 To 1)
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
End If
Next lngTemp2
Next lngTemp1
Next lngTemp
'Test for not base members to be have only one HIR
For lngTemp = 1 To lngRowsCount
lngTemp2 = 0
For lngTemp1 = 1 To lngHIRCount
If dctHIRArr(lngTemp1).Exists(strHIRArr(1, lngTemp)) Then
lngTemp2 = lngTemp2 + 1
End If
Next lngTemp1
If lngTemp2 > 1 Then
wshActiveSheet.Cells(lngTemp + 1, lngColNumArr(1)).Select
MsgBox "ERROR: Non base member " & _
strHIRArr(1, lngTemp) & " on the row: " & CStr(lngTemp + 1) & _
" has more then one parent!", , "Error!"
ReDim strHIRArr(1 To 1, 1 To 1)
Set dctProp = Nothing
For lngTemp3 = 1 To lngHIRCount
Set dctHIRArr(lngTemp3) = Nothing
Next lngTemp3
ReDim dctHIRArr(1 To 1)
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
If lngTemp2 = 1 Then
lngTemp4 = 0
For lngTemp1 = 3 To lngHIRCount + 2
If strHIRArr(lngTemp1, lngTemp) <> "" Then
lngTemp4 = lngTemp4 + 1
End If
Next lngTemp1
If lngTemp4 > 1 Then
wshActiveSheet.Cells(lngTemp + 1, lngColNumArr(1)).Select
MsgBox "ERROR: Non base member " & _
strHIRArr(1, lngTemp) & " on the row: " & CStr(lngTemp + 1) & _
" has more then one parent!", , "Error!"
ReDim strHIRArr(1 To 1, 1 To 1)
Set dctProp = Nothing
For lngTemp3 = 1 To lngHIRCount
Set dctHIRArr(lngTemp3) = Nothing
Next lngTemp3
ReDim dctHIRArr(1 To 1)
Set wshActiveSheet = Nothing
blnUnload = True
Exit Sub
End If
End If
Next lngTemp
For lngTemp = 1 To lngHIRCount
Set dctHIRArr(lngTemp) = Nothing
Next lngTemp
ReDim dctHIRArr(1 To 1)
ReDim lngColNumArr(1 To 1)
ReDim strPropArr(1 To lngRowsCount)
Me.trvTest.Style = tvwTreelinesPlusMinusText
Me.trvTest.LabelEdit = tvwManual
Me.trvTest.Appearance = cc3D
Me.trvTest.LineStyle = tvwRootLines
FillTree
End Sub
Private Sub AddChilds(strParent As String, lngHIR As Long, lngRootID)
Dim nodTemp As Node
Dim lngTemp As Long
Dim strTemp As String
For lngTemp = 1 To lngRowsCount
If CStr(lngRootID) & "N" & strHIRArr(lngHIR + 2, lngTemp) = strParent Then
If strPropArr(lngTemp) <> "" Then
strTemp = strHIRArr(1, lngTemp) & ": " & strHIRArr(2, lngTemp) & " " & strPropArr(lngTemp)
Else
strTemp = strHIRArr(1, lngTemp) & ": " & strHIRArr(2, lngTemp)
End If
Set nodTemp = Me.trvTest.Nodes.Add(strParent, tvwChild, CStr(lngRootID) & "N" & strHIRArr(1, lngTemp), _
strTemp)
nodTemp.Expanded = True
Set nodTemp = Nothing
AddChilds CStr(lngRootID) & "N" & strHIRArr(1, lngTemp), lngHIR, lngRootID
End If
Next lngTemp
End Sub
Private Sub FillTree()
Dim dctRoot As Scripting.Dictionary
Dim lngTemp As Long
Dim lngTemp1 As Long
Dim lngTemp2 As Long
Dim blnRootLine As Boolean
Dim varKeysArr() As Variant
Dim nodTemp As Node
Dim strTemp As String
Set dctRoot = New Scripting.Dictionary
dctRoot.CompareMode = BinaryCompare
lngTemp1 = 1
For lngTemp = 1 To lngRowsCount
blnRootLine = True
For lngTemp2 = 1 To lngHIRCount
If strHIRArr(lngTemp2 + 2, lngTemp) <> "" Then
blnRootLine = False
Exit For
End If
Next lngTemp2
If blnRootLine Then
dctRoot.Add CStr(lngTemp1) & "N" & strHIRArr(1, lngTemp), strHIRArr(1, lngTemp)
If strPropArr(lngTemp) <> "" Then
strTemp = strHIRArr(1, lngTemp) & ": " & strHIRArr(2, lngTemp) & " " & strPropArr(lngTemp)
Else
strTemp = strHIRArr(1, lngTemp) & ": " & strHIRArr(2, lngTemp)
End If
Set nodTemp = Me.trvTest.Nodes.Add(, , CStr(lngTemp1) & "N" & strHIRArr(1, lngTemp), _
strTemp)
lngTemp1 = lngTemp1 + 1
nodTemp.Expanded = True
End If
Next lngTemp
varKeysArr = dctRoot.Keys
For lngTemp = 0 To dctRoot.Count - 1
For lngTemp1 = 1 To lngHIRCount
AddChilds CStr(varKeysArr(lngTemp)), lngTemp1, lngTemp + 1
Next lngTemp1
Next lngTemp
Set dctRoot = Nothing
End Sub
Private Sub UserForm_Terminate()
ReDim strHIRArr(1 To 1, 1 To 1)
ReDim strPropArr(1 To 1)
Set dctProp = Nothing
Set wshActiveSheet = Nothing
End SubCreate a new module: modTestTree
Insert code in the Code window of this module:
Option Explicit
Public Sub ShowTree()
frmTree.Show
End SubOpen the Code window of ThisWorkbook
Insert code in the Code window of ThisWorkbook:
Option Explicit
Dim cControl As CommandBarButton
Private Sub Workbook_AddinInstall()
On Error Resume Next 'Just in case
'Delete any existing menu item that may have been left.
Application.CommandBars("Standard").Controls("CheckDim").Delete
'Add the new menu item and Set a CommandBarButton Variable to it
Set cControl = Application.CommandBars("Standard").Controls.Add(Type:=msoControlButton, ID:=2950)
With cControl
.Caption = "CheckDim"
.OnAction = "ShowTree"
.FaceId = 462
End With
On Error GoTo 0
End Sub
Private Sub Workbook_AddinUninstall()
On Error Resume Next 'In case it has already gone.
Application.CommandBars("Standard").Controls("CheckDim").Delete
On Error GoTo 0
End SubSave the file as checkdim.xla and install it.
B.R. Vadim
P.S. This Add-In can be used on BPC 10.x combined with BPC NW 10: VBA to get dimension members list and properties
- SAP Managed Tags:
7 Comments
