Financial Management Blogs by Members
Dive into a treasure trove of SAP financial management wisdom shared by a vibrant community of bloggers. Submit a blog post of your own to share knowledge.
cancel
Showing results for 
Search instead for 
Did you mean: 
former_member186338
Active Contributor


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 Sub

Create a new module: modTestTree

Insert code in the Code window of this module:
Option Explicit

Public Sub ShowTree()
frmTree.Show
End Sub

Open 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 Sub

Save 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

7 Comments