Option Explicit
Public Sub subRecordPrecedentsAndDependents()
Dim Ws As Worksheet
Dim rng As Range
Dim strCellRefs As String
Dim WsDependents As Worksheet
Dim WsPrecedents As Worksheet
Dim WsFormulas As Worksheet
Dim strWorksheets As String
Dim arrWorksheets() As String
Dim i As Integer
ActiveWorkbook.Save
Set WsDependents = fncCreateWorksheet("Dependents")
Set WsPrecedents = fncCreateWorksheet("Precedents")
Set WsFormulas = fncCreateWorksheet("Formulas")
WsDependents.Range("A1:F1").Value = Array("Worksheet", "Cell Ref", "Formula", "Worksheet In Formula", _
"Range In Formula", "Dependent Cell")
WsPrecedents.Range("A1:F1").Value = Array("Worksheet", "Cell Ref", "Formula", "Worksheet In Formula", _
"Range In Formula", "Precedent Cell")
WsFormulas.Range("A1:C1").Value = Array("Worksheet", "Cell Ref", "Formula")
For Each Ws In ActiveWorkbook.Worksheets
If Ws.Name <> "Dependents" And Ws.Name <> "Precedents" And Ws.Name <> "Formulas" Then
For Each rng In Ws.UsedRange.Cells
strCellRefs = fncExtractCellRefs(rng)
If strCellRefs <> "" Then
Call subSplitRanges(Ws.Name, rng, fncExtractCellRefs(rng))
ElseIf rng.HasFormula = True Then
With WsFormulas.Cells(WsFormulas.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 3)
.Value = Array(Ws.Name, rng.Address, Mid(rng.Formula, 2))
End With
End If
Next rng
End If
Next Ws
arrWorksheets = Split("Dependents,Precedents,Formulas", ",")
For i = LBound(arrWorksheets) To UBound(arrWorksheets)
Set Ws = Worksheets(arrWorksheets(i))
Call subFormatWorksheet(Ws)
Ws.Range("C1").EntireColumn.ColumnWidth = 55
Call subReconcileTextWrapping(Ws, "Formula", 30, 10)
Next i
Worksheets("Precedents").Activate
MsgBox "Precedents, Dependents and Formulas recorded.", vbInformation, "Confirmation"
ActiveWorkbook.Save
End Sub
Public Sub subReconcileTextWrapping(Ws As Worksheet, strHeader As String, intRowHeight As Integer, intSpacing As Integer)
Dim rng As Range
Dim intMax As Integer
Dim rngFound As Range
Dim rngToWrap As Range
Dim intCurrentHeight As Integer
Set rngFound = Ws.Rows(1).Find(strHeader, LookIn:=xlValues)
If Not rngFound Is Nothing Then
Set rngToWrap = rngFound.Offset(1, 0).Resize(Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row - 1, 1)
Else
Exit Sub
End If
For Each rng In rngToWrap
rng.WrapText = False
intCurrentHeight = rng.RowHeight
rng.WrapText = True
rng.EntireRow.AutoFit
intMax = rng.RowHeight
If intMax >= intCurrentHeight Then
rng.EntireRow.RowHeight = intMax + intSpacing
Else
rng.EntireRow.RowHeight = intRowHeight
End If
Next rng
End Sub
Private Sub subSplitRanges(strWorksheet As String, rng As Range, strRanges As String)
Dim arrSplit() As String
Dim i As Integer
Dim r As Range
Dim strWorksheetInFormula As String
arrSplit = Split(strRanges, ",")
For i = LBound(arrSplit) To UBound(arrSplit)
For Each r In Range(arrSplit(i)).Cells
With Worksheets("Precedents").Cells(Worksheets("Precedents").Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6)
strWorksheetInFormula = ""
If InStr(1, Trim(arrSplit(i)), "!", vbTextCompare) > 0 Then
strWorksheetInFormula = Left(Trim(arrSplit(i)), InStr(1, Trim(arrSplit(i)), "!", vbTextCompare) - 1)
Else
strWorksheetInFormula = strWorksheet
End If
.Value = Array(strWorksheet, rng.Address, _
Mid(rng.Formula, 2), _
strWorksheetInFormula, _
Trim(arrSplit(i)), _
r.Address)
With Worksheets("Dependents").Cells(Worksheets("Dependents").Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6)
.Value = Array(strWorksheetInFormula, _
r.Address, _
Mid(rng.Formula, 2), _
strWorksheetInFormula, _
Trim(arrSplit(i)), rng.Address)
End With
End With
Next r
Next i
End Sub
' Credit to https://www.extendoffice.com/documents/excel/4555-excel-extract-cell-reference-from-formula.html
Private Function fncExtractCellRefs(Rg As Range) As String
Dim xRetList As Object
Dim xRegEx As Object
Dim i As Long
Dim xRet As String
Application.Volatile
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
With xRegEx
.Pattern = "('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?"
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
Set xRetList = xRegEx.Execute(Rg.Formula)
If xRetList.Count > 0 Then
For i = 0 To xRetList.Count - 1
xRet = xRet & xRetList.Item(i) & ", "
Next
fncExtractCellRefs = Left(xRet, Len(xRet) - 2)
Else
fncExtractCellRefs = ""
End If
End Function
Private Function fncCreateWorksheet(strWorksheet As String) As Worksheet
Dim Ws As Worksheet
Dim blnCheck As Boolean
For Each Ws In Worksheets
If Ws.Name = strWorksheet Then
blnCheck = True
Ws.Cells.Clear
Exit For
End If
Next
If Not blnCheck = True Then
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = strWorksheet
End If
Worksheets(strWorksheet).Activate
Range("A2").Select
If ActiveWindow.FreezePanes Then
ActiveWindow.FreezePanes = False
End If
Set fncCreateWorksheet = ActiveSheet
End Function
Private Sub subFormatWorksheet(Ws As Worksheet)
Ws.Activate
With Ws.Range("A1").CurrentRegion
With .Rows(1)
.Interior.Color = RGB(213, 213, 213)
.Font.Bold = True
End With
.Font.Size = 14
.Font.Name = "Arial"
.RowHeight = 30
.VerticalAlignment = xlCenter
.IndentLevel = 1
.EntireColumn.AutoFit
End With
With Ws.Range("A1").CurrentRegion.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = vbBlack
End With
Range("A2").Select
If Not ActiveWindow.FreezePanes Then
ActiveWindow.FreezePanes = True
End If
End Sub
