' Adjust the values for the constants below to adjust the behavior of the macros
' Where to find the data
Public Const tableSheet As String = "RRCA Inputs"
Public Const nodeColumn As Long = 1
Public Const nodeTextColumn As Long = 3
Public Const nodeDispositionColumn As Long = 15
Public Const firstDataRow As Long = 2
' Where to put the data
Public Const treeSheet As String = "Fault Tree"
' Column widths for tree
Public Const nodeColumnWidth As Long = 14
Public Const spacingColumnWidth As Long = 4
' How to color code the tree. The following website has a table of the potential color options and their numbers
' http://msdn.microsoft.com/en-us/library/office/ff840443.aspx
' Level 1 items color
Public Const firstLevelColor As Long = 3 ' Red
' Open or no condition
Public Const openColor As Long = 16 ' Gray
' First severity level
Public Const severityCondition1 As String = "Unlikely"
Public Const conditionColor1 As Long = 4 ' Green
' Second severity level
Public Const severityCondition2 As String = "Non Contributor"
Public Const conditionColor2 As Long = 23 ' Blue
' Third severity level
Public Const severityCondition3 As String = "Likely"
Public Const conditionColor3 As Long = 6 ' Yellow.
' Fourth severity level
Public Const severityCondition4 As String = "Finding but Non Contributor"
Public Const conditionColor4 As Long = 46 ' Orange
' Fifth severity level
Public Const severityCondition5 As String = "Contributor"
Public Const conditionColor5 As Long = 3 ' Red
'================================================================================================================
'===================================== DO NOT ADJUST VALUES PAST THIS POINT =====================================
'================================================================================================================
' Public data variables used to store table data
Public levelNumber() As Long
Public itemColor() As Long
Public itemText() As String
Public lastDataRow As Long
Sub GenerateFaultTree()
' If tableSheet exists then grab data
If DoesSheetExist(tableSheet) Then
Call GetData(tableSheet)
' If sheet missing alert user
Else
Call MissingSheet(tableSheet)
Exit Sub
End If
' If treeSheet exists then grab data
If DoesSheetExist(treeSheet) Then
' Format sheet in preperation for tree build
Call PreFormatSheet(treeSheet)
' Build new tree
Call PlotData(treeSheet)
' If sheet missing alert user
Else
Call MissingSheet(treeSheet)
Exit Sub
End If
End Sub
Public Sub GetData(ByVal tableLocation As String)
Dim counter1, counter2 As Long
Dim returnSheet As String
Dim nodeSplit() As String
returnSheet = ActiveSheet.Name
' Turns off screen updating and alerts to substantially improve processing speed
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Move to form to capture data
Worksheets(tableLocation).Select
' Scrolls to top left to prevent errors
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
' Unhide all to prevent errors
Cells.EntireRow.Hidden = False
' Use filter to make sure rows are in the correct order
Range("A1").AutoFilter
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.AutoFilterMode = False
' Get last row of table
lastDataRow = ActiveSheet.Cells(Rows.count, 3).End(xlUp).row
ReDim levelNumber(lastDataRow)
ReDim itemColor(lastDataRow)
ReDim itemText(lastDataRow)
' Cycle through node list
For counter1 = firstDataRow To lastDataRow
' Get split out of node #
nodeSplit = Split(Cells(counter1, nodeColumn), ".")
' Scan each node split to determine tree level
For counter2 = UBound(nodeSplit) To 0 Step -1
' Look for a non 0 value
If nodeSplit(counter2) <> "0" And nodeSplit(counter2) <> "" Then
' Get parameters for the data
levelNumber(counter1) = counter2 + 1
itemText(counter1) = Cells(counter1, nodeTextColumn)
' Determine color coding for block
Select Case Cells(counter1, nodeDispositionColumn)
Case severityCondition1
itemColor(counter1) = conditionColor1
Case severityCondition2
itemColor(counter1) = conditionColor2
Case severityCondition3
itemColor(counter1) = conditionColor3
Case severityCondition4
itemColor(counter1) = conditionColor4
Case severityCondition5
itemColor(counter1) = conditionColor5
Case Else ' Open or none
itemColor(counter1) = openColor
End Select
' Color level 1 items seperately
If levelNumber(counter1) = 1 Then
itemColor(counter1) = firstLevelColor
End If
' Exit for loop
Exit For
End If
Next counter2
Next counter1
' Move back to fault tree
Worksheets(returnSheet).Select
' Turns screen updating and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub PreFormatSheet(ByVal treeLocation As String)
Dim counter1 As Long
' Move to form to capture data
Worksheets(treeLocation).Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
' Clear all
Columns("B:Z").Clear
' Remove lines from previous tree diagram
' Error modifications are there to prevent errors when a particular line does not exist
On Error Resume Next
For counter1 = 1 To 1000
ActiveSheet.Shapes("horizLine" & counter1).Delete
ActiveSheet.Shapes("vertLine" & counter1).Delete
Next counter1
On Error GoTo 0
' Presize column widths the same. Reduces likely hood of line drawing issues
Range("C:C,E:E,G:G,I:I,K:K,M:M,O:O,Q:Q,S:S,U:U,W:W,Y:Y").ColumnWidth = nodeColumnWidth
Range("B:B,D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T,V:V,X:X,Z:Z").ColumnWidth = spacingColumnWidth
' Format Key
Range("A2").Font.Size = 20
Range("A3:A4,A5:A6,A7:A8,A9:A10,A11:A12,A13:A14").MergeCells = True
Range("A2:A14").Font.Bold = True
' Create borders
With Range("A2:A14").Borders
.LineStyle = xlContinuous
.Weight = xlMedium
End With
' Generate color key
Range("A2") = "Color Key"
Range("A3:A4") = "Open"
Range("A3:A4").Interior.ColorIndex = openColor
Range("A5:A6") = severityCondition1
Range("A5:A6").Interior.ColorIndex = conditionColor1
Range("A7:A8") = severityCondition2
Range("A7:A8").Interior.ColorIndex = conditionColor2
Range("A9:A10") = severityCondition3
Range("A9:A10").Interior.ColorIndex = conditionColor3
Range("A11:A12") = severityCondition4
Range("A11:A12").Interior.ColorIndex = conditionColor4
Range("A13:A14") = severityCondition5
Range("A13:A14").Interior.ColorIndex = conditionColor5
' Center all in cells and turn on wrap text
With Cells
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
End Sub
Public Sub PlotData(ByVal treeLocation As String)
Dim counter1, counter2, counter3, counter4, counter5, counter6, currentTopPosition, currentHeight, currentRow As Long
Dim startX, startY, horizEndX, vertStartY, vertEndY As Double
Dim tempLine As Shape
Dim dropRow As Boolean
currentRow = 2
dropRow = False
' Turns off screen updating and alerts to substantially improve processing speed
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Move to form to capture data
Worksheets(treeLocation).Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
' Cycle through data
For counter1 = firstDataRow To lastDataRow
' Place node, color it, and border it
Cells(currentRow, levelNumber(counter1) * 2 + 1) = itemText(counter1)
Cells(currentRow, levelNumber(counter1) * 2 + 1).Interior.ColorIndex = itemColor(counter1)
Cells(currentRow, levelNumber(counter1) * 2 + 1).Borders.LineStyle = xlContinuous
' Check if level is level 1
If levelNumber(counter1) <> 1 Then
' If row is dropped then make line half into column before
If dropRow Then
startX = Cells(currentRow, levelNumber(counter1) * 2).Left + (Cells(currentRow, levelNumber(counter1) * 2).Width / 2)
startY = Cells(currentRow, levelNumber(counter1) * 2 + 1).Top + (Cells(currentRow, levelNumber(counter1) * 2 + 1).RowHeight / 2)
horizEndX = Cells(currentRow, levelNumber(counter1) * 2 + 1).Left
' Search for top of vertical line
For counter2 = currentRow - 1 To 2 Step -1
If Not IsEmpty(Cells(counter2, levelNumber(counter1) * 2 + 1)) Then
vertEndY = Cells(counter2, levelNumber(counter1) * 2 + 1).Top + (Cells(counter2, levelNumber(counter1) * 2 + 1).RowHeight / 2)
Exit For
End If
Next counter2
' Make vertical line
Set tempLine = ActiveSheet.Shapes.AddLine(startX, startY, startX, vertEndY)
With tempLine
.Name = "vertLine" & counter1
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 2
End With
Set tempLine = Nothing
' Else make line all the way across column before
Else
startX = Cells(currentRow, levelNumber(counter1) * 2 + -1).Left + Cells(currentRow, levelNumber(counter1) * 2 + -1).Width
startY = Cells(currentRow, levelNumber(counter1) * 2 + 1).Top + (Cells(currentRow, levelNumber(counter1) * 2 + 1).RowHeight / 2)
horizEndX = Cells(currentRow, levelNumber(counter1) * 2 + 1).Left
End If
' Create line,name and format
Set tempLine = ActiveSheet.Shapes.AddLine(startX, startY, horizEndX, startY)
With tempLine
.Name = "horizLine" & counter1
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 2
End With
Set tempLine = Nothing
End If
' Check to see if this is the last row of data
If counter1 <> lastDataRow Then
' If not last row of data decide whether or not to drop down 2 rows
If (levelNumber(counter1) >= levelNumber(counter1 + 1)) Then
currentRow = currentRow + 2
dropRow = True
Else
dropRow = False
End If
End If
Next counter1
' The below adjusts all line positions to account for changes in row heights
' Error modifications are there to prevent errors when a particular line does not exist
On Error Resume Next
' Cycle through lines
For counter3 = 2 To lastDataRow
' Fix horizontal lines
Set tempLine = Nothing
Set tempLine = ActiveSheet.Shapes("horizLine" & counter3)
currentTopPosition = tempLine.Top
' If line exists then find the row in which it lies
If Not tempLine Is Nothing Then
For counter4 = lastDataRow To 2 Step -1
' If row is found adjust line position to half way point of row
If currentTopPosition > Cells(counter4, 3).Top Then
tempLine.Top = Cells(counter4, 3).Top + (Cells(counter4, 3).RowHeight / 2)
Exit For
End If
Next counter4
End If
' Fix vertical lines
Set tempLine = Nothing
Set tempLine = ActiveSheet.Shapes("vertLine" & counter3)
currentTopPosition = tempLine.Top
currentHeight = tempLine.Height
' If line exists then find the rows in which its top and bottom points lie
If Not tempLine Is Nothing Then
' Search for top point row
For counter5 = lastDataRow To 2 Step -1
' If row is found adjust top point of line
If currentTopPosition > Cells(counter5, 3).Top Then
tempLine.Top = Cells(counter5, 3).Top + (Cells(counter5, 3).RowHeight / 2)
Exit For
End If
Next counter5
' Search for bottom point row
For counter6 = lastDataRow To 2 Step -1
' If row is found adjust bottom point of line
If (currentTopPosition + currentHeight) > Cells(counter6, 3).Top Then
tempLine.Height = (Cells(counter6, 3).Top + (Cells(counter6, 3).RowHeight / 2)) - currentTopPosition
Exit For
End If
Next counter6
End If
Next counter3
On Error GoTo 0
' Turns screen updating and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub MissingSheet(sheetName As String)
Call MsgBox("There is no sheet named """ & sheetName & """ in the active workbook. " _
& vbCrLf & "" _
& vbCrLf & "This sheet is needed for the operation of this macro. " _
& vbCrLf & "" _
& vbCrLf & "If the default name of the sheet the macro is looking for needs " _
& vbCrLf & "to be changed please update the constant value as the " _
& vbCrLf & "begining of the source code." _
, vbExclamation, "Fault Tree Builder")
End Sub
Function DoesSheetExist(sheetName As String, Optional workBookName As String) As Boolean
Dim wSheet As Worksheet
Dim sChar As Chart
On Error Resume Next
' Search active workbook
If workBookName = vbNullString Then
Set sChar = Charts(sheetName)
Set wSheet = Sheets(sheetName)
' Search specific workbook
Else
Set sChar = Workbooks(workBookName).Charts(sheetName)
Set wSheet = Workbooks(workBookName).Sheets(sheetName)
End If
On Error GoTo 0
' Return value
DoesSheetExist = Not sChar Is Nothing Or Not wSheet Is Nothing
End Function