Skip to Content
Technical Articles

Excel Add-In for BPC 7.5 to test Dimension

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

2 Comments
You must be Logged on to comment or reply to a post.