Created
January 16, 2021 02:55
-
-
Save vorpal56/97187f0fe2696019ce488a1e0fa615d7 to your computer and use it in GitHub Desktop.
Dependants and Precendents of Excel VBA
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Function fullAddress(inCell As Range) As String | |
fullAddress = Split(inCell.Address(External:=True), "]")(1) | |
End Function | |
Function findDepend(ByVal inRange As Range) As String | |
Dim sheetIdx As Integer | |
sheetIdx = Sheets(inRange.Parent.Name).Index | |
If sheetIdx = Worksheets.Count Then 'vba bug workaround | |
Sheets(sheetIdx - 1).Activate | |
Else | |
Sheets(Worksheets.Count).Activate | |
End If | |
Dim inAddress As String, returnSelection As Range | |
Dim i As Long, pCount As Long, qCount As Long | |
Set returnSelection = Selection | |
inAddress = fullAddress(inRange) | |
Application.ScreenUpdating = False | |
With inRange | |
.ShowPrecedents | |
.ShowDependents | |
.NavigateArrow False, 1 | |
Do Until fullAddress(ActiveCell) = inAddress | |
pCount = pCount + 1 | |
.NavigateArrow False, pCount | |
If ActiveSheet.Name <> returnSelection.Parent.Name Then | |
Do | |
qCount = qCount + 1 | |
.NavigateArrow False, pCount, qCount | |
findDepend = findDepend & fullAddress(Selection) & Chr(13) | |
On Error Resume Next | |
.NavigateArrow False, pCount, qCount + 1 | |
Loop Until Err.Number <> 0 | |
.NavigateArrow False, pCount + 1 | |
Else | |
findDepend = findDepend & fullAddress(Selection) & Chr(13) | |
.NavigateArrow False, pCount + 1 | |
End If | |
Loop | |
.Parent.ClearArrows | |
End With | |
With returnSelection | |
.Parent.Activate | |
.Select | |
End With | |
Sheets(sheetIdx).Activate 'activate original worksheet | |
End Function | |
Function findPrecedents(ByVal inRange As Range) As String | |
Dim sheetIdx As Integer | |
sheetIdx = Sheets(inRange.Parent.Name).Index | |
If sheetIdx = Worksheets.Count Then 'vba bug workaround | |
Sheets(sheetIdx - 1).Activate | |
Else | |
Sheets(Worksheets.Count).Activate | |
End If | |
Dim inAddress As String, returnSelection As Range | |
Dim i As Long, pCount As Long, qCount As Long | |
Set returnSelection = Selection | |
inAddress = fullAddress(inRange) | |
Application.ScreenUpdating = False | |
With inRange | |
.ShowPrecedents | |
.ShowDependents | |
.NavigateArrow True, 1 | |
Do Until fullAddress(ActiveCell) = inAddress | |
pCount = pCount + 1 | |
.NavigateArrow True, pCount | |
If ActiveSheet.Name <> returnSelection.Parent.Name Then | |
Do | |
qCount = qCount + 1 | |
.NavigateArrow True, pCount, qCount | |
findPrecedents = findPrecedents & fullAddress(Selection) & Chr(13) | |
On Error Resume Next | |
.NavigateArrow True, pCount, qCount + 1 | |
Loop Until Err.Number <> 0 | |
.NavigateArrow True, pCount + 1 | |
Else | |
findPrecedents = findPrecedents & fullAddress(Selection) & Chr(13) | |
.NavigateArrow True, pCount + 1 | |
End If | |
Loop | |
.Parent.ClearArrows | |
End With | |
With returnSelection | |
.Parent.Activate | |
.Select | |
End With | |
Sheets(sheetIdx).Activate 'activate original worksheet | |
End Function | |
Sub messageBoxCellDependents() | |
Dim SelRange As Range | |
Set SelRange = Selection | |
Dim contentString As String | |
contentString = "ok" | |
contentString = "Dependants of " & fullAddress(SelRange) & " are:" & vbCrLf & vbCrLf | |
MsgBox contentString & findDepend(SelRange) 'show user dependent cells in a pop up message box | |
End Sub | |
Sub messageBoxCellPrecedents() | |
Dim SelRange As Range | |
Set SelRange = Selection | |
Dim contentString As String | |
contentString = "ok" | |
contentString = "Precedents of " & fullAddress(SelRange) & " are:" & vbCrLf & vbCrLf | |
MsgBox contentString & findPrecedents(SelRange) 'show user dependent cells in a pop up message box | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment