PDA

View Full Version : if Dependent is not on the same sheet, then the cell will be given red colour



uktous
12-16-2013, 07:19 AM
Is It possible to a macro which can perform the following function?


For each cell in the selected area, if the cell has Dependents which is not on the same sheet, then the cell will be given red colour.

Thanks

Kenneth Hobs
12-16-2013, 07:48 AM
Yes. All dependent cells must be on the same worksheet then the that cell is red font color or interior color red?

uktous
12-16-2013, 08:06 AM
Yes. All dependent cells must be on the same worksheet then the that cell is red font color or interior color red?

interior color

thanks !

Kenneth Hobs
12-16-2013, 08:18 AM
Can you post an example workbook? Some people confuse dependents with precedents.

uktous
12-16-2013, 08:23 AM
i attached the file.

The Dependent of Sheet1 A1 is Sheet2 E4.

Kenneth Hobs
12-16-2013, 09:04 AM
I don't have time to tweak this right now for dependents and your need for interior color but concepts in this would be used.


Sub FindPrecedents()
' written by Bill Manville
' With edits from PaulS
' this procedure finds the cells which are the direct precedents of the active cell
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub

uktous
12-16-2013, 09:09 AM
As I suspected, you want precedents. I don't have time to tweak this right now but concepts in this would be used.


Sub FindPrecedents()
' written by Bill Manville
' With edits from PaulS
' this procedure finds the cells which are the direct precedents of the active cell
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub



I have used your macro.
What I need is Dependent. (I am sure.)
Could you please help again and create a similar macro for dependent?

Thanks

Kenneth Hobs
12-16-2013, 09:34 AM
There is no need to quote the code that I posted.

As I said, I don't have time right now to tweak it for you but the concept would the same for dependents. I wanted to show that it is doable. I think it will get more involved if the references are to an external workbook. Howsoever, the dependents for such a reference would be near impossible. I will check back tonight when I have more time to see if anyone solved it by then. If not, I will finish it out for you.

Kenneth Hobs
12-16-2013, 12:24 PM
Since I had time at lunch, I tweaked it for you.


Sub Test_HasOtherDependentSheet()
MsgBox HasOtherDependentSheet(Activecell)
End Sub

Sub Test2_HasOtherDependentSheet()
Dim c As Range
For Each c In Selection
If HasOtherDependentSheet(c) Then
c.Interior.Color = vbRed
Else
c.Interior.Color = xlNone
End If
Next c
End Sub

Function HasOtherDependentSheet(Acell As Range) As Boolean
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
Activecell.ShowDependents
Set rLast = Acell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
Activecell.NavigateArrow TowardPrecedent:=False, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = Activecell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = Activecell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = Activecell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
'MsgBox "Dependents are" & stMsg
HasOtherDependentSheet = InStr(1, stMsg, "!") > 0
End Function

mikerickson
12-17-2013, 07:42 AM
Perhaps

Sub test()
Dim oneCell As Range

For Each oneCell In Sheet1.Range("A1:B6")
If HasOffSheetDependents(oneCell) Then
oneCell.Interior.ColorIndex = 3
Else
oneCell.Interior.ColorIndex = xlNone
End If
Next oneCell
End Sub

Function HasOffSheetDependents(aCell As Range) As Boolean
aCell.ShowDependents
HasOffSheetDependents = (aCell.NavigateArrow(False, 1, 1).Parent.Name <> aCell.Parent.Name)
aCell.Parent.ClearArrows
End Function

The .NavigateArrow function always puts all off-sheet precedent/dependents on arrow 1.