Malicious Office (OOXML) / .XLSX — malware analysis report

Attribute VB_Name = "Sheet_RiskAssessment_Row_add_de"
' erstellt von MBT Ostermann GmBH

'Insert a new row directly after the selected row.
'Copy values of certain columns (EHSR-No, EHSR-Headline, EHSR-Regulation, EHSR-Original, EHSR-emptyHeadline, EHSR-sort, EHSR-mandatory).
'For all columns ending in "-Document-number":
'call ResetDocumentNumberValidations header, cell.
'For column RiskEstimation-hazardCovered:
'copy the validation rule,
'set the value to "-" (stored as text).
Sub AddRiskAssessmentRow()
    Dim tbl As ListObject
    Dim ws As Worksheet
    Dim selRow As listRow
    Dim newRow As listRow
    Dim srcCell As Range, tgtCell As Range
    Dim colName As Variant

    'No change is shown, while Macro is running
    Application.ScreenUpdating = False
    'No Macro is triggered by this Macro
    Application.EnableEvents = False
    
    Set ws = Sheet_RiskAssessment
    Set tbl = ws.ListObjects("Table_RiskAssessment")

    ' Ensure selection is inside the table
    If Intersect(Selection, tbl.DataBodyRange) Is Nothing Then
        MsgBox Sheet_Language.Range("MacroText_SelectTableRA").Value, vbExclamation
        Exit Sub
    End If

    ' Identify the selected row
    Set selRow = tbl.ListRows(Selection.row - tbl.HeaderRowRange.row)

    ' Insert a new row after the selected one
    Set newRow = tbl.ListRows.Add(selRow.index + 1)

    ' Copy specific columns from selected row
    Dim copyCols As Variant
    copyCols = Array("EHSR-No", "EHSR-Headline", "EHSR-Regulation", _
                     "EHSR-emptyHeadline", _
                     "EHSR-sort", "EHSR-mandatory", "EHSR-Exists")

    For Each colName In copyCols
        Set srcCell = selRow.Range.Cells(1, tbl.ListColumns(colName).index)
        Set tgtCell = newRow.Range.Cells(1, tbl.ListColumns(colName).index)
        srcCell.Copy
        tgtCell.PasteSpecial Paste:=xlPasteAll
    Next colName

    ' Reset validations for *-Document-number columns
    Dim docCols As Variant
    docCols = Array("ProductLimits-Document-number", _
                    "Hazard-Description-Document-number", _
                    "RiskReduction-Document-number")

    For Each colName In docCols
        Set tgtCell = newRow.Range.Cells(1, tbl.ListColumns(colName).index)
        ResetDocumentNumberValidations CStr(colName), tgtCell
    Next colName

    ' RiskEstimation-hazardCovered: copy validation, set to "-"
    Set srcCell = selRow.Range.Cells(1, tbl.ListColumns("RiskEstimation-hazardCovered").index)
    Set tgtCell = newRow.Range.Cells(1, tbl.ListColumns("RiskEstimation-hazardCovered").index)
    srcCell.Copy
    tgtCell.PasteSpecial Paste:=xlPasteValidation
    tgtCell.Value = "'-"

    Application.CutCopyMode = False

    'No change is shown, while Macro is running
    Application.ScreenUpdating = True
    'No Macro is triggered by this Macro
    Application.EnableEvents = True
End Sub

'clone the current row into the next row — while leaving UID and EHSR-Original empty
'- Ensures user selected a row in Table_RiskAssessment.
'- Inserts a new row directly after the selected row.
'- Copies all cells (values, formulas, validations, formatting).
'- Clears UID and EHSR-Original in the new row.
Sub CopyRiskAssessmentRow()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim selRow As listRow
    Dim newRow As listRow
    Dim colUID As ListColumn, colOriginal As ListColumn

    Set ws = Sheet_RiskAssessment
    Set tbl = ws.ListObjects("Table_RiskAssessment")

    ' Ensure a cell in the table is selected
    If Intersect(Selection, tbl.DataBodyRange) Is Nothing Then
        MsgBox Sheet_Language.Range("MacroText_SelectTableRA").Value, vbExclamation
        Exit Sub
    End If

    'No change is shown, while Macro is running
    Application.ScreenUpdating = False
    'No Macro is triggered by this Macro
    Application.EnableEvents = False

    ' Identify the selected row
    Set selRow = tbl.ListRows(Selection.row - tbl.HeaderRowRange.row)

    ' Insert a new row after the selected row
    Set newRow = tbl.ListRows.Add(selRow.index + 1)

    ' Copy whole row at once (values, formats, formulas, validations)
    selRow.Range.Copy
    newRow.Range.PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

    ' Clear UID and EHSR-Original
    Set colUID = tbl.ListColumns("UID")
    Set colOriginal = tbl.ListColumns("EHSR-Original")

    newRow.Range.Cells(1, colUID.index).ClearContents
    newRow.Range.Cells(1, colOriginal.index).ClearContents

    'No change is shown, while Macro is running
    Application.ScreenUpdating = True
    'No Macro is triggered by this Macro
    Application.EnableEvents = True
End Sub


Sub DeleteRiskAssessmentRows()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim colOriginal As ListColumn, colExists As ListColumn, colMandatory As ListColumn
    Dim keepCols As Variant, i As Long, j As Long
    'Dim hazardList As ListObject
    Dim firstVal As String
    Dim secondVal As String
    Dim area As Range, rng As Range
    Dim rowIndex As Long
    Dim uniqueRows As Object  ' Scripting.Dictionary
    Dim delIdx() As Long, delCount As Long
    Dim clrIdx() As Long, clrCount As Long
    Dim selRow As listRow
    Dim c As ListColumn
    Dim keepMap As Object     ' Scripting.Dictionary for fast membership check
    Dim key As Variant
    Dim b_AutoFillFormulas As Boolean

    ' ---- Speed up ----
    b_AutoFillFormulas = StartOfMacroEventhandling
    
    On Error GoTo Cleanup

    Set ws = Sheet_RiskAssessment
    Set tbl = ws.ListObjects("Table_RiskAssessment")

    ' Must be inside the table
    If Intersect(Selection, tbl.DataBodyRange) Is Nothing Then
        MsgBox Sheet_Language.Range("MacroText_SelectTableRA").Value, vbExclamation
        GoTo Cleanup
    End If

    ' Confirm
    If MsgBox("This action will irreversibly delete or clear data in the selected rows. Continue?", _
              vbExclamation + vbYesNo) = vbNo Then GoTo Cleanup

    ' Needed columns
    Set colOriginal = tbl.ListColumns("EHSR-Original")
    Set colExists = tbl.ListColumns("EHSR-Exists")
    Set colMandatory = tbl.ListColumns("EHSR-mandatory")

    ' 2nd value from List_RA_HazardExists (language-agnostic "no")
    secondVal = "=" & getDropDownCell("EHSR-Exists", 2).Address(True, True, xlA1, True)
    firstVal = "=" & getDropDownCell("EHSR-Exists", 1).Address(True, True, xlA1, True)

    ' Build array of column indexes to keep (for the "clear" case)
    keepCols = Array( _
        tbl.ListColumns("EHSR-No").index, _
        tbl.ListColumns("EHSR-Headline").index, _
        tbl.ListColumns("EHSR-Regulation").index, _
        tbl.ListColumns("EHSR-emptyHeadline").index, _
        tbl.ListColumns("EHSR-sort").index, _
        colMandatory.index, _
        colOriginal.index)

    ' Fast membership map for keepCols
    Set keepMap = CreateObject("Scripting.Dictionary")
    For i = LBound(keepCols) To UBound(keepCols)
        keepMap(keepCols(i)) = True
    Next i

    ' Collect unique table row indexes from the selection
    Set uniqueRows = CreateObject("Scripting.Dictionary")
    For Each area In Selection.Areas
        For Each rng In area.Rows
            rowIndex = rng.row - tbl.HeaderRowRange.row
            If rowIndex > 0 And rowIndex <= tbl.ListRows.Count Then
                uniqueRows(CStr(rowIndex)) = CLng(rowIndex)
            End If
        Next rng
    Next area

    ' Categorize rows: which to clear vs delete (decide before any structural change)
    For Each key In uniqueRows.Keys
        rowIndex = CLng(uniqueRows(key))
        Set selRow = tbl.ListRows(rowIndex)
        If Trim(CStr(selRow.Range.Cells(1, colOriginal.index).Value)) = "" Then
            ' delete
            delCount = delCount + 1
            ReDim Preserve delIdx(1 To delCount)
            delIdx(delCount) = rowIndex
        Else
            ' clear
            clrCount = clrCount + 1
            ReDim Preserve clrIdx(1 To clrCount)
            clrIdx(clrCount) = rowIndex
        End If
    Next key

    ' First: clear rows (no structural change, any order)
    For i = 1 To clrCount
        Set selRow = tbl.ListRows(clrIdx(i))
        For Each c In tbl.ListColumns
            If Not keepMap.Exists(c.index) Then
                selRow.Range.Cells(1, c.index).ClearContents
            End If
        Next c
        ' reset EHSR-Exists to 2nd list item (link)
        selRow.Range.Cells(1, colExists.index).Formula = secondVal
        ' if mandatory, set to yes
        If selRow.Range.Cells(1, colMandatory.index).Value <> "" Then
            selRow.Range.Cells(1, colExists.index).Formula = firstVal
        End If
    Next i

    ' Then: delete rows (descending order to avoid index shift)
    If delCount > 1 Then
        ' simple descending sort
        For i = 1 To delCount - 1
            For j = i + 1 To delCount
                If delIdx(i) < delIdx(j) Then
                    rowIndex = delIdx(i)
                    delIdx(i) = delIdx(j)
                    delIdx(j) = rowIndex
                End If
            Next j
        Next i
    End If
    For i = 1 To delCount
        tbl.ListRows(delIdx(i)).Delete
    Next i

Cleanup:
    EndOfMacroEventhandling b_AutoFillFormulas
End Sub



Attribute VB_Name = "DieseArbeitsmappe"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
' erstellt von MBT Ostermann GmBH

Private Sub Workbook_Open()
    ' check a flag to skip the version check (user previously chose Ignore)
    If Not isSet("macro_WB_checkForNewVersion") Then
        Exit Sub
    End If
    
    Dim http As Object
    Dim latestVersion As String
    Dim currentVersion As String
    Dim checkURL As String
    Dim openURL As String
    Dim userChoice As VbMsgBoxResult
    
    ' URLs
    checkURL = "https://www.maschinenrichtlinie.de/fileadmin/veroeffentlichungen/MBT-RAT/MBT-RAT-Version.txt"
    openURL = "https://www.maschinenrichtlinie.de/index.php?id=10341"
    
    ' Current version from named range
    currentVersion = Trim(Sheet_Version.Range("MBT_RAT_Version").Value)
    
    ' Attempt to fetch online version
    On Error GoTo Offline
    
    Sheet_Version.Range("E2").ClearContents
    
    With Sheet_Version.QueryTables.Add( _
        Connection:="URL;https://www.maschinenrichtlinie.de/fileadmin/veroeffentlichungen/MBT-RAT/MBT-RAT-Version.txt", _
        Destination:=Sheet_Version.Range("E2"))
        .BackgroundQuery = False
        .Refresh
    End With
    
    latestVersion = Trim(Sheet_Version.Range("E2").Value)
    
        ' Compare versions
        If latestVersion <> currentVersion Then
            userChoice = MsgBox(Sheet_Language.Range("MacroText_VersionCheck1").Value & latestVersion & vbCrLf & _
                                Sheet_Language.Range("MacroText_VersionCheck2").Value & currentVersion & vbCrLf & vbCrLf & _
                                Sheet_Language.Range("MacroText_VersionCheck3").Value & vbCrLf & _
                                Sheet_Language.Range("MacroText_VersionCheck4").Value & vbCrLf & _
                                Sheet_Language.Range("MacroText_VersionCheck5").Value, _
                                vbYesNoCancel + vbExclamation, "Update Available")
            
            Select Case userChoice
                Case vbYes
                    ' Open website
                    ThisWorkbook.FollowHyperlink openURL
                    
                Case vbNo
                    ' Set a flag to skip future checks
                    doSet "macro_WB_checkForNewVersion", False
                    
                Case vbCancel
                    ' Do nothing, keep checking next time

            End Select
        End If
    
    Exit Sub

Offline:
    ' Skip silently if offline or any HTTP error occurs
    Exit Sub
End Sub


Attribute VB_Name = "Sheet_RiskAssessment"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
' erstellt von MBT Ostermann GmBH

'switch MBT-RAT Ribbon on and off
'causing the Riskassessment part of the ribbon to appear
Private Sub Worksheet_Activate()
    ReloadRibbonMBTRAT
End Sub

'switch MBT-RAT Ribbon on and off
'causing the Riskassessment part of the ribbon to disappear
Private Sub Worksheet_Deactivate()
    ReloadRibbonMBTRAT
End Sub


'Detects changes in Table_RiskAssessment.
'Supports individual column triggers.
'Supports grouped columns (e.g., a range of columns triggers a shared macro once).
'Each macro receives:
'    The changed headers.
'    The changed cells (Range).
'    The changed area (Target).
'To define:
'    A colTriggers dictionary for single-column triggers.
Private Sub Worksheet_Change(ByVal Target As Range)
    ' If too many cells changed, skip for performance
    If RangeExists("Sheet_Setup", "macro_RA_maxCellsChange") Then
        Dim maxChanged As Long
        maxChanged = Sheet_Setup.Range("macro_RA_maxCellsChange")   ' <-- limiter, adjust as needed
        If Target.CountLarge > maxChanged Then Exit Sub
    End If
    
    'check general macro switches, if macros shall be executed
    If Not isSet("macro_execute") Or Not isSet("macro_RA_execute") Then Exit Sub
    
    Dim tbl As ListObject
    Set tbl = Me.ListObjects("Table_RiskAssessment")
    
    'check if change affects Table_RiskAssessment
    If Intersect(Target, tbl.DataBodyRange) Is Nothing Then Exit Sub
    
    Dim colTriggers As Object
    Set colTriggers = CreateObject("Scripting.Dictionary")
    
    ' Individual column triggers
    If isSet("macro_RA_EHSR_exists") Then _
        colTriggers.Add LCase("EHSR-Exists"), Array("MandatoryEHSR", "ChangeEHSR")
    If isSet("macro_RA_Hazard_12100_group") Then _
        colTriggers.Add LCase("Hazard-12100-group"), Array("ValueLeftOfReference")
    If isSet("macro_RA_Document_Number") Then
        colTriggers.Add LCase("ProductLimits-Document-number"), Array("StandardNumberComplete", "StandardNameSelect", "StandardTypeSelect", "ResetDocumentNumberValidations")
        colTriggers.Add LCase("Hazard-Description-Document-number"), Array("StandardNumberComplete", "StandardNameSelect", "StandardTypeSelect", "ResetDocumentNumberValidations")
        colTriggers.Add LCase("RiskReduction-Document-number"), Array("StandardNumberComplete", "StandardNameSelect", "StandardTypeSelect", "ResetDocumentNumberValidations")
    End If 'macro_RA_Document_Number
    If isSet("macro_RA_Hazard_PhasesOfLife_all") Then _
        colTriggers.Add LCase("Hazard-PhasesOfLife-all"), Array("Enter_All_Lifecycles")
    If isSet("macro_RA_RiskEstimation_hazardCovered") Then _
        colTriggers.Add LCase("RiskEstimation-hazardCovered"), Array("CheckEHSRcovered")
    'triggers for rows starting with RiskEvaluation*
    If isSet("macro_RA_RiskEvaluation_allowStandard") Then
        colTriggers.Add LCase("RiskEvaluation-standard"), Array("copyStandardRiskValue")
        colTriggers.Add LCase("RiskEvaluationAfter-standard"), Array("copyStandardRiskValue")
    End If 'macro_RA_RiskEvaluation_allowStandard
    If isSet("macro_RA_RiskEvaluation_Calculate") Then
        colTriggers.Add LCase("RiskEvaluation-13849-severity"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluation-13849-frequency"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluation-13849-possibility"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluation-13849-probability"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluation-62061-severity"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluation-62061-frequency"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluation-62061-possibility"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluation-62061-probability"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluation-882e-severity"), Array("calculateNew882eValue")
        colTriggers.Add LCase("RiskEvaluation-882e-probability"), Array("calculateNew882eValue")
        colTriggers.Add LCase("RiskEvaluationAfter-13849-severity"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluationAfter-13849-frequency"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluationAfter-13849-possibility"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluationAfter-13849-probability"), Array("calculateNew13849Value")
        colTriggers.Add LCase("RiskEvaluationAfter-62061-severity"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluationAfter-62061-frequency"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluationAfter-62061-possibility"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluationAfter-62061-probability"), Array("calculateNew62061Value")
        colTriggers.Add LCase("RiskEvaluationAfter-882e-severity"), Array("calculateNew882eValue")
        colTriggers.Add LCase("RiskEvaluationAfter-882e-probability"), Array("calculateNew882eValue")
    End If 'macro_RA_RiskEvaluation_Calculate
    If isSet("macro_RA_RiskEvaluation_NumberToText") Then
        colTriggers.Add LCase("RiskReduction-Solution-Information-srpcs"), Array("recalculateRiskValue")
    End If 'macro_RA_RiskEvaluation_NumberToText
    
    ' --- Other macro flags ---
    ' pre looked up, to save processing time later on isSet()
    Dim bLogChanges As Boolean
    bLogChanges = isSet("macro_RA_LogChanges")
    Dim bSetDateOfLastChange As Boolean
    bSetDateOfLastChange = isSet("macro_RA_SetDateOfLastChange")
    Dim bGetFormulaFromList As Boolean
    bGetFormulaFromList = isSet("macro_RA_ListToFormula")
    
    ' --- Prevent recursive events ---
    'disables Private Sub Worksheet_Change() for changes (!recursive)
    Dim UserAutoFillFormulasInLists As Boolean
    UserAutoFillFormulasInLists = StartOfMacroEventhandling
    
    ' --- Process each changed cell ---
    Dim cell As Range, colIndex As Long, header As String, headerKey As String
    Dim macroList As Variant, macroName As Variant
    'only work on cells within the table
    For Each cell In Intersect(Target, tbl.DataBodyRange).Cells
        colIndex = cell.column - tbl.Range.Columns(1).column + 1
        If colIndex >= 1 And colIndex <= tbl.ListColumns.Count Then
            header = tbl.HeaderRowRange.Cells(1, colIndex).Value
            headerKey = LCase(header)

            ' --- Macros run on every cell ---
            If bGetFormulaFromList And HasValidationList(cell) Then
                GetFormulaFromList header, cell
            End If
            If bLogChanges Then Log_Changes cell
            If bSetDateOfLastChange And Not (header = "Comment-dateOfChange") Then _
                Set_Date_of_Lastchange cell


            ' --- Individual triggers ---
            If colTriggers.Exists(headerKey) Then
                macroList = colTriggers(headerKey)
                For Each macroName In macroList
                    Application.Run macroName, header, cell
                    'runs: Sub macroName(header As String, cell As Range)
                Next macroName
            End If
        End If 'colIndex
    Next cell

'Cleanup:
    EndOfMacroEventhandling (UserAutoFillFormulasInLists)
End Sub

Attribute VB_Name = "Sheet_StandardTitle"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_Activate()
    ReloadRibbonMBTRAT
End Sub

Private Sub Worksheet_Deactivate()
    ReloadRibbonMBTRAT
End Sub

Attribute VB_Name = "Sheet_ENISO12100"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "ZOLD_change_language"
Sub Select_Language_OLD(Optional ByVal selectLanguage As Integer = -1)
Attribute Select_Language_OLD.VB_Description = "Changes the selected language and fills out the special fields"
Attribute Select_Language_OLD.VB_ProcData.VB_Invoke_Func = " \n14"
' erstellt von MBT Mechtersheimer GbR
' Select_Language Makro
' Changes the selected language and fills out the special fields

'
    'disable Private Sub Worksheet_Calculate() for next changes (!recursive)
    StartOfMacroEventhandling
    
    Dim intLanguage As Integer
    Dim intMaxLanguage As Integer
    
    'increase the language by 1 or reset to 1 if at the end
    intLanguage = Range("Language_select").Value
    intMaxLanguage = getNumberOfLanguages
    
    'new since version > 2.3.4.3
    'if no language is selected, next language is selected
    If -1 = selectLanguage Then
        If (intLanguage = intMaxLanguage) Then
            intLanguage = 1
        Else
            intLanguage = intLanguage + 1
        End If
    Else
        'new since version > 2.3.4.3
        'direct selection possible
        intLanguage = selectLanguage
    End If
    
    Dim strLanguage As String
    strLanguage = ""
    If intLanguage = 1 Then
        strLanguage = "_Ger"
    End If
    If intLanguage = 2 Then
        strLanguage = "_Eng"
    End If
    
    'put new value in the language select sheet and in the sheet for user specific fields
    Range("Language_select").Value = intLanguage
    Range("Language_Select_Own").Value = intLanguage
    
    'normal cells have been updated, now the special fields (buttons, comments, checkboxes) need to be updated
    With Table_ProjectData
        'comments:
        .Range("Project_Leader").Comment.text text:=Range("Information_Name_Company_Function").Value
        .Range("Mechanical_Designer").Comment.text text:=Range("Information_Name_Company_Function").Value
        .Range("Electrical_Designer").Comment.text text:=Range("Information_Name_Company_Function").Value
        .Range("Control_System_Designer").Comment.text text:=Range("Information_Name_Company_Function").Value
        .Range("Communication_Medium_Designer").Comment.text text:=Range("Information_Name_Company_Function").Value
        .Range("authorised_person").Comment.text text:=Range("Information_authorised_person").Value
        .Range("Overview_Drawing").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Requirement_Design_Spec").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Technical_Spec").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Description_on_Setup").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Technical_Data").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Lifcycle_machine").Comment.text text:=Range("Information_20years").Value
        .Range("Lifecycle_wear_parts").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Recommanded_maintenance").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Materials_processed").Comment.text text:=Range("Information_Filename_Version").Value
        .Range("Necessary_cleanliness").Comment.text text:=Range("Information_Necessary_cleanliness").Value
        .Range("Max_min_temperature").Comment.text text:=Range("Information_Max_min_temperature").Value
        .Range("Max_min_temperature_environment").Comment.text text:=Range("Information_Max_min_temperature").Value
        .Range("Operation_in_out").Comment.text text:=Range("Information_Operation_in_out").Value
        .Range("dust_moisture").Comment.text text:=Range("Information_dust_moisture").Value
        
        'the name of the worksheet is changed
        .Name = Range("Name_Table_ProjectData").Value
        
        'dropped since version > 2.5
        'Project Data has check boxes
        '.CheckBoxes("xxx").Caption = Range("xxx").Value
        
        'Text fields in forms
        .Shapes.Range(Array("Textfield_Instructions")).TextFrame2.TextRange.Characters.text = Range("Content_Textfield_Instructions" & strLanguage).Value
        .Shapes.Range(Array("Textfield_Copyrights")).TextFrame2.TextRange.Characters.text = Range("Content_Textfield_Copyrights" & strLanguage).Value & Range("Content_Textfield_Version").Value
        .Shapes.Range(Array("Textfield_License")).TextFrame2.TextRange.Characters.text = Range("Content_Textfield_License" & strLanguage).Value
        .Shapes.Range(Array("Textfield_Refresh_Standards")).TextFrame2.TextRange.Characters.text = Range("Content_Textfield_Refresh_Standards").Value
        .Shapes.Range(Array("Button_Setup_Projectdata")).TextFrame2.TextRange.Characters.text = Range("Name_Setup").Value
        'new since v2.5
        .Shapes.Range(Array("Button_Print_RiskAssessment")).TextFrame2.TextRange.Characters.text = Range("Content_Button_PrintRA").Value
    End With 'Table_ProjectData
    
    With Table_RiskAssessment
        'comments:
        .Range("EHSR").Comment.text text:=Range("Information_EHSR").Value
        .Range("Content").Comment.text text:=Range("Information_Content").Value
        .Range("Normtype").Comment.text text:=Range("Information_Normtype").Value
        .Range("Cell_RiskAssessment").Comment.text text:=Range("Information_RiskAssessment").Value
        .Range("Cell_RiskAssessment2").Comment.text text:=Range("Information_RiskAssessment").Value
        .Range("Further_reduction").Comment.text text:=Range("Information_Further_reduction").Value
        .Range("Hazard_is_done").Comment.text text:=Range("Information_Hazard_is_done").Value
    
        'the name of the worksheet is changed
        .Name = Range("Name_Table_RiskAssessment").Value
        'the GroupBox that has the add / remove line
        .Shapes.Range(Array("Insert_Delete_Rows_Field")).TextFrame.Characters.text = Range("Text_Insert_Delete_Rows_Field").Value
        .Shapes.Range(Array("Textfield_Copyrights")).TextFrame2.TextRange.Characters.text = Range("Content_Textfield_Copyrights" & strLanguage).Value & Range("Content_Textfield_Version").Value
        .Shapes.Range(Array("Button_Setup_RiskAssessment")).TextFrame2.TextRange.Characters.text = Range("Name_Setup").Value
    End With 'Table_RiskAssessment
    
    With Table_BStandard
        .Name = Range("Name_Table_BStandard").Value
    End With
    
    With Table_ENISO12100
        .Name = Range("Name_Table_ENISO12100").Value
    End With
    
    With Table_Language
        .Name = Range("Name_Table_Language").Value
    End With
    
    With Table_OwnCells
        .Name = Range("Name_Table_OwnCells").Value
    End With
    
    With Table_RiskAssessment_Log
        .Name = Range("Name_Table_RiskAssessment_Log").Value
    End With
    
    'formulas for StandardNumbers are automated by macro since v2.5.5
    'previous coding was cut here
    
    EndOfMacroEventhandling
End Sub

Attribute VB_Name = "Sheet_ProjectData"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
' erstellt von MBT Ostermann GmBH

Private Sub Worksheet_Change(ByVal Target As Range)
' erstellt von MBT Mechtersheimer GbR
' Worksheet_Change Makro
    If Not isSet("macro_execute") Then
        Exit Sub
    End If
    If Not isSet("macro_PD_execute") Then
        Exit Sub
    End If
    
    'disable Private Sub Worksheet_Change() for next changes (!recursive)
    StartOfMacroEventhandling
    
    'get the formula for a list entry, not the list entry itself
    'otherwise, translation does not work
    If HasValidation(Target) And isSet("macro_PD_ListToFormula") Then
        'Target.Formula = GetFormulaFromList("Content", Target)
        GetFormulaFromList "Content", Target
    End If
    
    'enable Private Sub Worksheet_Change()
    EndOfMacroEventhandling
End Sub




Attribute VB_Name = "Sheet_Language"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet_OwnCells"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet_RiskAssessment_DropDown"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet_Version"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet_RiskAssessment_Log"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_Activate()
    ReloadRibbonMBTRAT
End Sub

Private Sub Worksheet_Deactivate()
    ReloadRibbonMBTRAT
    If isSet("macro_RALog_HideOnLeave") Then
        Sheet_RiskAssessment_Log.Visible = xlSheetHidden
    End If
End Sub



Attribute VB_Name = "Sheet_RiskAssessment_EHSR_chang"
' erstellt von MBT Ostermann GmBH
Sub MandatoryEHSR(header As String, cell As Range)
    Dim yesCell As Range
    'Dim valYes As String
    
    ' --- Load Yes/No/Unknown from language-specific list ---
    Set yesCell = getDropDownCell("EHSR-Exists", 1)
    
    If isMandatoryEHSR(cell) Then
        cell.Formula = "=" & yesCell.Address(True, True, xlA1, True)
    End If
End Sub

Function isMandatoryEHSR(cell As Range) As Boolean
'EHSR-mandatory from EHSR-Exists
    Dim tbl As ListObject
    Dim colMandatory As ListColumn
    Dim listRow As listRow
   
    Set tbl = Sheet_RiskAssessment.ListObjects("Table_RiskAssessment")

    Set colMandatory = tbl.ListColumns("EHSR-mandatory")

    Set listRow = tbl.ListRows(cell.row - tbl.HeaderRowRange.row)

    If LCase(listRow.Range.Cells(1, colMandatory.index).Value) = "x" Then
        isMandatoryEHSR = True
    Else
        isMandatoryEHSR = False
    End If
End Function

Sub ChangeEHSR(header As String, cell As Range)
    Dim tbl As ListObject
    Dim colExists As ListColumn, colNo As ListColumn, colRegulation As ListColumn
    Dim listRow As listRow
    Dim currentNo As String, currentRegulation As String
    Dim valYes As String, valNo As String, valUnknown As String
    Dim yesCell As Range, noCell As Range, unknownCell As Range
    Dim newValue As String
    
    ' --- Load Yes/No/Unknown from language-specific list ---
    Set yesCell = getDropDownCell("EHSR-Exists", 1)
    Set noCell = getDropDownCell("EHSR-Exists", 2)
    Set unknownCell = getDropDownCell("EHSR-Exists", 3)
    valYes = CStr(yesCell.Value)
    valNo = CStr(noCell.Value)
    valUnknown = CStr(unknownCell.Value)
    
    ' --- Get the table and columns ---
    Set tbl = Sheet_RiskAssessment.ListObjects("Table_RiskAssessment")
    Set colExists = tbl.ListColumns("EHSR-Exists")
    Set colNo = tbl.ListColumns("EHSR-No")
    Set colRegulation = tbl.ListColumns("EHSR-Regulation")
    
    ' --- Get the exact ListRow containing "cell" ---
    Set listRow = tbl.ListRows(cell.row - tbl.HeaderRowRange.row)
    
    ' --- Get current chapter and regulation ---
    currentNo = CleanChapterNumber(CStr(listRow.Range.Cells(1, colNo.index).Value))
    currentRegulation = CStr(listRow.Range.Cells(1, colRegulation.index).Value)
    newValue = CStr(listRow.Range.Cells(1, colExists.index).Value)
    
    ' --- Decide which formula to link ---
    Select Case newValue
        Case valYes
            NewFormula = "=" & yesCell.Address(True, True, xlA1, True)
        Case valNo
            NewFormula = "=" & noCell.Address(True, True, xlA1, True)
        Case valUnknown
            NewFormula = "=" & unknownCell.Address(True, True, xlA1, True)
        Case Else
            Exit Sub ' Not one of Yes/No/Unknown
    End Select

    Dim r As listRow
    Dim ch As String, reg As String
    
    If newValue = valYes Then
        ' Set all parent chapters to yes
        For Each r In tbl.ListRows
            ch = CleanChapterNumber(CStr(r.Range.Cells(1, colNo.index).Value))
            reg = CStr(r.Range.Cells(1, colRegulation.index).Value)
            If reg = currentRegulation Then
                If IsParentChapter(ch, currentNo) Then
                    r.Range.Cells(1, colExists.index).Formula = NewFormula
                End If
            End If
        Next r
        
    ElseIf newValue = valNo Or newValue = valUnknown Then
        ' Set all subchapters to no/unknown
        For Each r In tbl.ListRows
            ch = CleanChapterNumber(CStr(r.Range.Cells(1, colNo.index).Value))
            reg = CStr(r.Range.Cells(1, colRegulation.index).Value)
            If reg = currentRegulation Then
                If IsParentChapter(currentNo, ch) Then
                    If Not isMandatoryEHSR(r.Range.Cells(1, colExists.index)) Then
                        r.Range.Cells(1, colExists.index).Formula = NewFormula
                    End If
                End If
            End If
        Next r
    End If
End Sub

' Normalize a chapter string: remove whitespace, NBSP, leading/trailing dots/spaces
Private Function CleanChapterNumber(ch As Variant) As String
    Dim t As String

    ' Handle Null or Error input
    If IsError(ch) Then
        CleanChapterNumber = ""
        Exit Function
    End If
    If IsNull(ch) Then
        CleanChapterNumber = ""
        Exit Function
    End If
    If Trim(CStr(ch)) = "" Then
        CleanChapterNumber = ""
        Exit Function
    End If

    t = CStr(ch)

    ' Replace non-breaking spaces and remove CR/LF
    t = Replace(t, ChrW(160), " ")
    t = Replace(t, vbCr, "")
    t = Replace(t, vbLf, "")

    ' Remove leading/trailing spaces and periods
    t = Trim(t)
    Do While Len(t) > 0 And (Right(t, 1) = "." Or Right(t, 1) = " ")
        t = Left(t, Len(t) - 1)
    Loop
    Do While Len(t) > 0 And (Left(t, 1) = "." Or Left(t, 1) = " ")
        t = Mid(t, 2)
    Loop

    CleanChapterNumber = Trim(t)
End Function



' True if "possibleParent" is a strict parent of "possibleChild".
' Compares token-by-token so "1.2" is parent of "1.2.4" but NOT of "1.20".
Private Function IsParentChapter(possibleParent As String, possibleChild As String) As Boolean
    Dim p As String, c As String
    Dim pTok As Variant, cTok As Variant
    Dim i As Long

    p = CleanChapterNumber(possibleParent)
    c = CleanChapterNumber(possibleChild)
    If p = "" Or c = "" Then Exit Function
    If p = c Then Exit Function

    ' quick reject: parent must have fewer tokens than child
    pTok = Split(p, ".")
    cTok = Split(c, ".")
    If UBound(pTok) >= UBound(cTok) Then Exit Function

    ' compare tokens case-insensitive and trimmed
    For i = LBound(pTok) To UBound(pTok)
        If LCase(Trim(pTok(i))) <> LCase(Trim(cTok(i))) Then
            Exit Function
        End If
    Next i

    IsParentChapter = True
End Function



Attribute VB_Name = "helperSubFunc"
' erstellt von MBT Ostermann GmBH
'Helper Functions and Sub that subsitute repetitve code

Function RemoveFiltersFromTable(w As Worksheet) As Variant
    'code taken from Peter_SSs from the following site:
    'http://www.mrexcel.com/forum/excel-questions/333961-capture-autofilter-state.html
'    Set w = ActiveSheet
'   selection needs to be in table
'   TODO:replace w with tablename
    
    Dim Filter_active As Boolean
    Filter_active = False
    'remember all filters
    Dim filterArray()
    Dim col As Integer
    
    ' Capture AutoFilter settings
    With w.AutoFilter.Filters
        ReDim filterArray(1 To .Count, 1 To 3)
        For f = 1 To .Count
            With .item(f)
                If .On Then
                    Filter_active = True
                    filterArray(f, 1) = .Criteria1
                    If .Operator Then
                        filterArray(f, 2) = .Operator
                        'filterArray(f, 3) = .Criteria2 not needed in Excel 2010 ff.
                    End If
                End If
            End With
        Next f
    End With
    
    'Remove AutoFilter
    If Filter_active = True Then
        w.ShowAllData
    End If
    
    RemoveFiltersFromTable = filterArray
End Function

Sub RestoreFiltersFromTable(filterArray As Variant, w As Worksheet)
    'reset all filters
    Dim currentFiltRange As String
    currentFiltRange = w.AutoFilter.Range.Address
'_________________________________________________________________________________________
    'code taken from Peter_SSs from the following site:
    'http://www.mrexcel.com/forum/excel-questions/333961-capture-autofilter-state.html
    ' Restore Filter settings
    
    For col = 1 To UBound(filterArray, 1)
        If Not IsEmpty(filterArray(col, 1)) Then
            If filterArray(col, 2) Then
                w.Range(currentFiltRange).AutoFilter Field:=col, _
                Criteria1:=filterArray(col, 1), _
                Operator:=filterArray(col, 2), _
                Criteria2:=filterArray(col, 3)
            Else
                w.Range(currentFiltRange).AutoFilter Field:=col, _
                Criteria1:=filterArray(col, 1)
            End If
        End If
    Next col
'_________________________________________________________________________________________
End Sub

'certain funtions of Excel need to be disabled,
'before internal Macros start working on content
' returns Boolean (Application.AutoCorrect.AutoFillFormulasInLists)
Function StartOfMacroEventhandling() As Boolean
    'No change is shown, while Macro is running
    Application.ScreenUpdating = False
    'No Macro is triggered by this Macro
    Application.EnableEvents = False
    'Eingaben in Excel werden geblockt, solange das Makro läuft
    Application.Interactive = False
    'formeln in Tabellen werden nicht automatisch aufgefüllt
    StartOfMacroEventhandling = Application.AutoCorrect.AutoFillFormulasInLists
    Application.AutoCorrect.AutoFillFormulasInLists = False
    'stop calculating formulas
    Application.Calculation = xlCalculationManual
End Function

'certain funtions of Excel need to be enabled,
'after internal Macros finished working on content
'Inputs:
' UserAutoFillFormulasInLists - was returned by StartOfMacroEventhandling
Sub EndOfMacroEventhandling(Optional ByVal UserAutoFillFormulasInLists As Boolean = True)
' erstellt von MBT Mechtersheimer GbR
' ResetRunningSubs Makro
' fürs Debugging: wenn ein Skript abbricht, werden keine anderen automatischen Skripte mehr ausgeführt
' for debugging purpose: if a script stops with an error, no other automated scripts will run

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Interactive = True
…