Show failures in Excel Form Report

For example, if a dimension is failing, the Excel spreadsheet will have that cell colored Red.

You have to make that in your own Excel report with conditional formatting.

Only thing is that PCDMIS overwrites the conditionings so you have to inssert it after creating the report.

You can do this with Visual Basic (BVA).

Hexagon emailed me the '25 part study' template,  in there you can find  VBA code which you can use as an example  and build further on.

Create a Personal.XLSB 

Create new Module Excel_Form_Report_PcDmis

Add this code example: (This is a beta version for example purposes only)

Sub A__Dimensional_Report_Form_Row_Highlight()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

'On Error Resume Next
On Error Resume Next

'Check that Sheet Measure exists
Dim sht As Worksheet
Dim shtName As String
Dim cKshT As Boolean

shtName = "Measure"
cKshT = True
For Each sht In Worksheets
If sht.Name = shtName Then
Sheets("Measure").Select
cKshT = False
ElseIf cKshT = True Then
MsgBox "Sheet Tab " & shtName & " is not there in the workbook." & vbNewLine & vbNewLine & _
"Open a workbook that has a Sheet Tab with " & shtName
Exit Sub
End If
Next sht

'Check for data in the first cell
Dim myRange As Range
Dim myCell As Range
Dim CheckCell As Range
Dim CheckCellColor As Range
Dim emptyCell As Boolean
Dim SingleCell As Boolean
Dim ColorNumberSelect As Boolean

emptyCell = False
SingleCell = False
ColorNumberSelect = False

Set myRange = Range("G13")
For Each myCell In myRange
If IsEmpty(myCell) Then
emptyCell = True
End If
Next myCell

'Check for data in the first and second Column cell
Set CheckCell = Range("G13:G14")
For Each myCell In CheckCell
If IsEmpty(myCell) Then
SingleCell = True
End If
Next myCell

'Highlight Cell if there is no empty cells in the first and second Column cells
If emptyCell = False Then

'Check for data in the Color setting for Red Yellow Green cell
Set CheckCellColor = Worksheets("Stats").Range("M1")
For Each myCell In CheckCellColor
If IsEmpty(myCell) Then
ColorNumberSelect = True
End If
Next myCell

Set CheckCellColor = Worksheets("Stats").Range("Q1")
For Each myCell In CheckCellColor
If IsEmpty(myCell) Then
ColorNumberSelect = True
End If
Next myCell

Dim percentTol As Double
Dim colorSelect As Integer

If ColorNumberSelect = False Then
colorSelect = CInt(Worksheets("Stats").Range("M1").Value)
percentTol = CDbl(Worksheets("Stats").Range("Q1").Value) * 0.01
Else
Dim Message, Title, Default, MyValue
Message = "Enter 1 for Red only, 2 for Red and Yellow , " & vbNewLine & _
"3 for Red, Yellow and Green" & vbNewLine & vbNewLine & _
"(Default value is 2 for Red and Yellow)" ' Set prompt.
Title = "Color Selector" ' Set title.
Default = "2" ' Set default.
' Display message, title, and default value.
ColorValue = InputBox(Message, Title, Default)
If ColorValue = "" Then Exit Sub
colorSelect = CInt(ColorValue)

Message = "Enter a percentage of tolerance value 0 thru 100 " & vbNewLine & vbNewLine & _
"Default value is 75 for the Yellow Highlight" ' Set prompt.
Title = "Percentage of Tolerance" ' Set title.
Default = "75" ' Set default.
' Display message, title, and default value.
PercentValue = InputBox(Message, Title, Default)
If PercentValue = "" Then Exit Sub
percentTol = CDbl(PercentValue) * 0.01

' Use Helpfile and context. The Help button is added automatically.
' MyValue = InputBox(Message, Title, , , , "DEMO.HLP", 10)

' Display dialog box at position 100, 100.
' MyValue = InputBox(Message, Title, Default, 100, 100)
End If

Sheets("Measure").Select

Dim rg As Range

'Base on single or range of cell with data to be selected
If SingleCell = True Then
Range("G13").Select
Range(Selection, Selection).Select
Else
Range("G13", "SL13").Select
Range(Selection, Selection.End(xlDown)).Select
End If


Set rg = Selection

'clear any existing conditional formatting
Selection.Interior.ColorIndex = xlNone

Dim rowNum As Integer
Dim nomCell As Variant
Dim ucell As Double
Dim lcell As Double
Dim ulimit As Double
Dim lLimit As Double
Dim meaValue As Double
Dim zeroTol As Double
Dim posTol As Double

Dim counter As Integer
counter = 1

For Each Cell In rg

'If counter = 1 Then GoTo SkipCondition
nomCell = CDbl(Range("D" & Cell.Row).Value)
ucell = CDbl(Range("E" & Cell.Row).Value)
ucellP = CDbl(Range("E" & Cell.Row).Value) * percentTol
lcell = CDbl(Range("F" & Cell.Row).Value)
lcellP = CDbl(Range("F" & Cell.Row).Value) * percentTol

meaValue = CDbl(Cell.Value)

zeroTol = ucell - lcell
posTol = nomCell - lcell
ulimit = nomCell + ucell
ulimitP = nomCell + ucellP
lLimit = nomCell + lcell
lLimitP = nomCell + lcellP

If (meaValue <> 0 And zeroTol <> 0) Then
If colorSelect = 2 Or colorSelect = 3 Then
'Upper Limits
If (meaValue >= ulimitP And meaValue <= ulimit) Then
Worksheets("Measure").Activate
Cell.Interior.Color = RGB(255, 255, 150) 'vbYellow '
ElseIf colorSelect = 3 And (meaValue <= ulimitP And meaValue >= nomCell) Then
Worksheets("Measure").Activate
Cell.Interior.Color = RGB(102, 255, 150) 'vbGreen '
End If
'Lower Limits
If (meaValue <= lLimitP And meaValue >= lLimit) Then
Worksheets("Measure").Activate
Cell.Interior.Color = RGB(255, 255, 150) 'vbYellow '
ElseIf colorSelect = 3 And (meaValue >= lLimitP And meaValue < nomCell) Then
Worksheets("Measure").Activate
Cell.Interior.Color = RGB(102, 255, 150) 'vbGreen '
End If
End If
'Over the Limits

If colorSelect = 1 Or colorSelect = 2 Or colorSelect = 3 Then
If (meaValue < lLimit Or meaValue > ulimit) Then
If (posTol <> 0) Then
Worksheets("Measure").Activate
Cell.Interior.Color = RGB(255, 130, 130) 'vbRed '
Else
Worksheets("Measure").Activate
Cell.Interior.Color = RGB(255, 199, 206) 'vbYellow 'Red Bad RGB(255, 199, 206) 'Yellow Neutral RGB(255, 235, 156)
End If
End If
End If
End If

'Used for testing only to break out of the loop.
'Dim answer As Integer
'answer = MsgBox("Loop Number: " & counter & " ", vbQuestion + vbYesNoCancel)
'counter = counter + 1
'If answer = vbCancel Then GoTo LoopExit

Next

Range(Selection, Selection).Copy
Sheets("Deviation").Range("G13").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("Deviation").Select
Range("A1:B1").Select
Sheets("Measure").Select
Range("A1:B1").Select
Application.CutCopyMode = False

'Used for testing only to break out of the loop.
LoopExit:

'If the first cell is empty
ElseIf emptyCell = True Then
MsgBox _
"Not enough data found" & vbNewLine & _
vbNewLine & _
"Form Needs at least one reported Dimensions"
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Sub B__Dimensional_Report_Form_Row_Highlight_Clear()

'Clears the Conditional Formating.

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

'On Error Resume Next
On Error Resume Next

Dim sht As Worksheet
Dim shtName As String
Dim cKshT As Boolean

'Check that Sheet Measure exists
shtName = "Measure"
cKshT = True
For Each sht In Worksheets
If sht.Name = shtName Then
cKshT = False
ElseIf cKshT = True Then
MsgBox "Sheet Tab " & shtName & " is not there in the workbook." & vbNewLine & vbNewLine & _
"Open a workbook that has a Sheet Tab with " & shtName
Exit Sub
End If
Next sht

Dim myRange As Range
Dim myCell As Range
Dim emptyCell As Boolean

emptyCell = False

Sheets("Measure").Select
'Check for data in the first cell
Set myRange = Range("G13")
For Each myCell In myRange
If IsEmpty(myCell) Then
emptyCell = True
End If
Next myCell

'Check for data in the first and second Column cell
If emptyCell = True Then
MsgBox _
"Not enough data found" & vbNewLine & _
vbNewLine & _
"Form Needs at least one reported Dimensions"
Exit Sub
End If

Dim rg As Range


Range("G13", "SL13").Select
Range(Selection, Selection.End(xlDown)).Select

'clear any existing conditional formatting
Selection.Interior.ColorIndex = xlNone

' Method below only work with more than one dimension entry
'Range(Selection, Selection).Copy
'Sheets("Deviation").Range("G13").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
'SkipBlanks:=False, Transpose:=False
'Application.CutCopyMode = False

Sheets("Deviation").Select

Range("G13", "SL13").Select
Range(Selection, Selection.End(xlDown)).Select

'clear any existing conditional formatting
Selection.Interior.ColorIndex = xlNone

Sheets("Deviation").Select
Range("A1:B1").Select
Sheets("Measure").Select
Range("A1:B1").Select

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Then you can Add the View Macros to the Customize Quick Access Toolbar to view all of the Macro's.

This will work for the Excel extension .xlsx and .xlsm. For each Macro use the Options... to add the Shortcut Keys Ctrl+ your key choice.

Follow this link to 

Create and save all your macros in a single workbook