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