White Rabbit scan report navigation

After creating a scan report. Open Excel, click the Developer option, then Visual Basic.Double click this workbook and paste in the following vb code. Go to the top of the code and run the subroutine “format_White_rabbit()”. The code may take a few minutes to complete.When finished, there will be links from the table overview to the field overview and from the field overview to the specific worksheet for the table. On the field overview page rows with a high fraction empty will be gray. You can save the workbook with back as .xlsx so that it is not macro enabled.
No warranty, no support, just something I found helpful

Sub format_White_rabbit()
'    RemoveDBO
    WR_formatSheets
    WR_format_field_overview
    WR_table_link
    WR_field_link
    grayEmptyFields
    select_a2
    
    Worksheets("Table Overview").Activate
    
End Sub


Private Sub WR_table_link()

    Dim row As Integer
    Dim NumRows As Integer
    Dim tableRowNumber As Integer
    Dim TARGET As String
    Dim tableCell As Range

    Application.ScreenUpdating = False
    Worksheets("Table Overview").Activate
    
    Sheets("Table Overview").Select
    Sheets("Table Overview").Move Before:=Sheets(1)

    Worksheets("Table Overview").Activate
    NumRows = get_last_row
    For row = 2 To NumRows
        Worksheets("Table Overview").Activate
        Set tableCell = ActiveSheet.Range(Cells(row, 1), Cells(row, 1))
        tableCell.Select
        If tableCell.Value = vbNullString Then GoTo EndForLoop
        
        tableRowNumber = getFirstTableRow("Field Overview", tableCell.Value)
        TARGET = "'Field Overview'!A" + CStr(tableRowNumber)
        
        ' table overview to field overview link
        Worksheets("Table Overview").Activate
        ActiveSheet.Range(Cells(row, 1), Cells(row, 1)).Select
        ActiveCell.Hyperlinks.Delete
        ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=TARGET
        
        
        ' field overview to table link
        Worksheets("Field Overview").Activate
        ActiveSheet.Range(Cells(tableRowNumber, 1), Cells(tableRowNumber, 1)).Select
        TARGET = "'Table Overview'!A" + CStr(row)
        ActiveCell.Hyperlinks.Delete
        ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=TARGET
           
    
EndForLoop:
    Next row
    
    Application.ScreenUpdating = True
End Sub


Private Sub WR_field_link()
' Create hyperlinks for each table/Column to the sheet and column in
' the detail sheet.  Also hyperlink back from the detail column to
' the entry on the Field Overview sheet
    
    Dim row As Integer
    Dim NumRows As Integer
    Dim tableCell As Range
    Dim columnCell As Range
    Dim targetColumn As Integer
    Dim TARGET As String
    Dim detailCell As Range
    Dim maxTabNameLen As Integer
    Dim tabName As String
    
    maxTabNameLen = 30
    
    Worksheets("Field Overview").Activate
    
    Application.ScreenUpdating = False
    
    NumRows = get_last_row
    
      ' Establish "For" loop to loop "numrows" number of times.
      For row = 2 To NumRows
       Worksheets("Field Overview").Activate
        Set tableCell = Worksheets("Field Overview").Range(Cells(row, 1), Cells(row, 1))
        tableCell.Select
        
        If tableCell.Value = vbNullString Then GoTo EndForLoop
        
        tabName = Left(tableCell.Value, maxTabNameLen)
       
        Set columnCell = Worksheets("Field Overview").Range(Cells(row, 2), Cells(row, 2))
        
        targetColumn = getColumnNumber(tabName, columnCell.Value)

        TARGET = tabName + "!" + Cells(1, targetColumn).Address
    
        columnCell.Activate
        
        columnCell.Hyperlinks.Delete
        columnCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=TARGET
        
        
        ' Now link the other direction
        Worksheets(tabName).Activate
        Range("A1").Select
        
        Set detailCell = Range(Cells(1, targetColumn), Cells(1, targetColumn))
        TARGET = "'Field Overview'" + "!" + columnCell.Address
        
        detailCell.Activate
        detailCell.Hyperlinks.Delete
        detailCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=TARGET
         
EndForLoop:
      Next row
    Worksheets("Field Overview").Activate
    
    Application.ScreenUpdating = True
End Sub


Private Function getColumnNumber(ByVal workSheetName As String, ByVal headerText As String) As Integer
' Get the column number for the headerText.  Assumes headers are in
' row one and that the header exists
' returns the column number

Dim columnNumber As Integer
Dim columns As Integer
Dim headerCell As Range
Dim currentActiveSheet As Worksheet
    
    getColumnNumber = 0
    Set currentActiveSheet = ActiveSheet
    Worksheets(workSheetName).Activate
    With ActiveSheet
      
    columns = get_last_column
    
    For columnNumber = 1 To columns
        Set headerCell = Range(Cells(1, columnNumber), Cells(1, columnNumber))
        If headerCell.Value = headerText Then
            currentActiveSheet.Activate
            getColumnNumber = columnNumber
            Exit Function
        End If
    Next
   End With
   currentActiveSheet.Activate
End Function
Private Function getFirstTableRow(ByVal workSheetName As String, ByVal TableName As String) As Integer
' Get the first row number that matches the tableName
    Dim rowNumber As Integer
    Dim rows As Long
    
    getFirstTableRow = 0
    Worksheets(workSheetName).Activate
    rows = get_last_row
   
    For rowNumber = 2 To rows
        If Range(Cells(rowNumber, 1), Cells(rowNumber, 1)).Value = TableName Then
            getFirstTableRow = rowNumber
            Exit Function
        End If
    Next
End Function

 Private Sub WR_formatSheets()
  ' Freeze top row
  ' Change Frequency to Freq
  ' Bold headings
  ' Auto fit columns

         Dim WS_Count As Integer
         Dim i As Integer
         Dim sht As Worksheet
         
         Application.ScreenUpdating = False
      
         ' Set WS_Count equal to the number of worksheets in the active
         ' workbook.
         WS_Count = ActiveWorkbook.Worksheets.Count

         ' Begin the loop.
         For i = 1 To WS_Count
            Set sht = ActiveWorkbook.Worksheets(i)
            sht.Activate
            
            ' remove prior hyper links
            Cells.Select
            Selection.Hyperlinks.Delete
            
            ' Freeze top row
            rows("2:2").Select
            ActiveWindow.FreezePanes = True
            
            ' Bold top row text
            Range("A1", Range("A1").End(xlToRight)).Select
            Selection.Font.Bold = True
            
            ' Replace Frequency with Freq
            Cells.Replace What:="frequency", Replacement:="Freq", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
            
           ' select entire sheet and auto fit
            Cells.Select
            Cells.EntireColumn.AutoFit

         Next i

        Application.ScreenUpdating = True
      End Sub

Private Sub WR_format_field_overview()
' Ask if user want to sort by table/column
' Put a space before each new table
' Filter on table

    Dim answer As Integer
    Dim rowCount As Integer
    Dim currentRow As Integer
    Dim priorTableName As String
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim i As Integer
    Dim sht As Worksheet
    

    answer = MsgBox("Sort Field Overview by Table/Column?" _
                  , vbQuestion + vbYesNoCancel + vbDefaultButton2, "White Rabbit Formater")
    If answer = vbCancel Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    If answer = vbYes Then
    
     Worksheets("Table Overview").Activate
    lastRow = get_last_row
        lastColumn = get_last_column
         ' sort by table
        With ActiveWorkbook.Worksheets("Table Overview").Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1"), Order:=xlAscending
            .SetRange Range(Cells(1, 1), Cells(lastRow, lastColumn))
            .Header = xlYes
            .Apply
        End With
    
    Worksheets("Field Overview").Activate
    lastRow = get_last_row
        lastColumn = get_last_column
         ' sort by table/column
        With ActiveWorkbook.Worksheets("Field Overview").Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1"), Order:=xlAscending
            .SortFields.Add Key:=Range("B1"), Order:=xlAscending
            .SetRange Range(Cells(1, 1), Cells(lastRow, lastColumn))
            .Header = xlYes
            .Apply
        End With

    'Sort detail tables by column name
        For i = 1 To ActiveWorkbook.Worksheets.Count
            Set sht = ActiveWorkbook.Worksheets(i)
            sht.Activate
            If sht.Name = "Table Overview" Then GoTo continueFor
            
            If sht.Name = "Field Overview" Then GoTo continueFor
            
            If sht.Name = "_" Then GoTo continueFor
                      
            sortColumn
continueFor:
         Next i
    
        ' Sort the sheets with with Rabbit results by name
        sortSheets
    End If ' sort
    
    Worksheets("Field Overview").Activate
    'Delete any blank rows at the top
    rowCount = get_last_row
    currentRow = 2
    While Range(Cells(currentRow, 1), Cells(currentRow, 1)).Value = "" _
      And currentRow < rowCount 'this second test just incase
        If Range(Cells(currentRow, 1), Cells(currentRow, 1)).Value = "" Then
            rows(currentRow).Delete
            rowCount = rowCount - 1
        Else
            currentRow = currentRow + 1
        End If
    Wend
    
    'Insert a blank line above each new table definition
    rowCount = get_last_row
    currentRow = 2
    priorTableName = Range(Cells(currentRow, 1), Cells(currentRow, 1)).Value
    While currentRow < rowCount
        If Not priorTableName = Range(Cells(currentRow, 1), Cells(currentRow, 1)).Value _
            And Not Range(Cells(currentRow, 1), Cells(currentRow, 1)).Value = "" Then
            
            priorTableName = Range(Cells(currentRow, 1), Cells(currentRow, 1)).Value
            If Not Range(Cells(currentRow - 1, 1), Cells(currentRow - 1, 1)).Value = "" Then
                rows(currentRow).Insert
                rowCount = rowCount + 1
            End If ' already a blank line
        End If 'table name changed
        currentRow = currentRow + 1
    Wend
    
    Application.ScreenUpdating = True
    End Sub

Private Sub select_a2()
    Dim i As Integer
    Dim sht As Worksheet
         
    Application.ScreenUpdating = False
   
    WS_Count = ActiveWorkbook.Worksheets.Count

    For i = 1 To WS_Count
        Set sht = ActiveWorkbook.Worksheets(i)
        With sht
            .Activate
            'To remove any panes
            ActiveWindow.FreezePanes = False
            'Select the second row
            .rows("2:2").Select
            'Apply Freeze
            ActiveWindow.FreezePanes = True
        End With
        Cells(2, 1).Select
    Next i
    Application.ScreenUpdating = True
End Sub
 Private Function get_last_row() As Long
  'get the last row of current sheet
    
    get_last_row = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlValues, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).row


End Function

 Private Function get_last_column() As Long
  ' get last column of current sheet
    
    get_last_column = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column

End Function

Sub RemoveDBO()
'
' RemoveDBO Macro
'
    Application.ScreenUpdating = False
        
    Worksheets("Table Overview").Activate
      
    Cells.Replace What:="dbo.", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False _
        , FormulaVersion:=xlReplaceFormula2
                      
    Worksheets("Field Overview").Activate
      
    Cells.Replace What:="dbo.", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False _
        , FormulaVersion:=xlReplaceFormula2
        
   Dim WS_Count As Integer
   Dim sht As Worksheet
   Dim sheetName As String
   Dim newName As String
  

   ' Set WS_Count equal to the number of worksheets in the active
   ' workbook.
   WS_Count = ActiveWorkbook.Worksheets.Count

   ' Begin the loop.
    For i = 1 To WS_Count
      Set sht = ActiveWorkbook.Worksheets(i)
      sht.Activate
      sheetName = ActiveSheet.Name
      If InStr(sheetName, "dbo.") > 0 Then
        newName = Right(sheetName, Len(sheetName) - Len("dbo."))
        ActiveSheet.Name = newName
      End If
      
    Next i
      
  Application.ScreenUpdating = True
End Sub

Sub grayEmptyFields()
    Dim rowCount As Integer
    Dim fieldColumn As Integer
    
    rowCount = get_last_row
    fieldColumn = 2

    Worksheets("Field Overview").Activate

    Range(Cells(2, fieldColumn), Cells(rowCount, fieldColumn)).Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=H2>=0.99"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.14996795556505
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub



Sub sortColumn()
'Sort active sheet column by column header value
    Dim lastColumn As Integer
    Dim i   As Integer
    Dim iAdjust As Integer
    Dim j   As Integer
    Dim h1 As String
    Dim h2 As String
    Dim sorted As Boolean
   
    sorted = False
    lastColumn = get_last_column()
    
    Do While sorted = False
        sorted = True  'will get set to false if more to do
        For i = 1 To lastColumn Step 2
            iAdjust = 0
            For j = i + 2 To lastColumn Step 2
                h1 = Cells(1, i + iAdjust).Value
                h2 = Cells(1, j).Value
                If StrComp(h1, h2, 1) > 0 Then
                   sorted = False
                   Range(columns(j), columns(j + 1)).Select
                   Selection.Cut
                   columns(i + iAdjust).Select
                   Selection.Insert Shift:=xlToRight
                   iAdjust = iAdjust + 2
               End If
            Next j
        Next i
    Loop
    

End Sub

Sub sortSheets()
'Sort sheets by sheet name
    Dim lastSheet As Integer
    Dim firstSheet As Integer
    
    Dim i   As Integer
    Dim iAdjust As Integer
    Dim j   As Integer
    Dim h1 As String
    Dim h2 As String
    Dim sorted As Boolean
   
    sorted = False
    firstSheet = 1
    ' get first sheet after Notes, Table Overview, Field Overview
    If sheetExist("Notes") Then
        firstSheet = 2
        If Sheets("Notes").Index <> 1 Then
            Worksheets("Notes").Move Before:=ActiveWorkbook.Sheets(1)
        End If
    End If ' Notes exists
    
    If Sheets("Table Overview").Index <> firstSheet Then
        Worksheets("Table Overview").Move Before:=ActiveWorkbook.Sheets(firstSheet)
    End If ' Table Overview
    
    firstSheet = firstSheet + 1
    
    If Sheets("Field Overview").Index <> firstSheet Then
         Worksheets("Field Overview").Move Before:=ActiveWorkbook.Sheets(firstSheet)
    End If ' Field Overview
    
    firstSheet = firstSheet + 1
    lastSheet = ActiveWorkbook.Worksheets.Count
    
    Do While sorted = False
        sorted = True  'will get set to false if more to do
        For i = firstSheet To lastSheet
            iAdjust = 0
            For j = i + 1 To lastSheet
                h1 = ActiveWorkbook.Worksheets(i + iAdjust).Name
                h2 = ActiveWorkbook.Worksheets(j).Name
                If StrComp(h1, h2, 1) > 0 Then
                   sorted = False
                   ActiveWorkbook.Worksheets(j).Move Before:=ActiveWorkbook.Worksheets(i + iAdjust)
                   iAdjust = iAdjust + 1
               End If
            Next j
        Next i
    Loop
    

End Sub

Function sheetExist(sSheet As String) As Boolean
    On Error Resume Next
    sheetExist = ActiveWorkbook.Sheets(sSheet).Index
End Function