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

[uktous]

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]

Yes. All dependent cells must be on the same worksheet then the that cell is red font color or interior color red?

[uktous]

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]

Can you post an example workbook? Some people confuse dependents with precedents.

[uktous]

i attached the file.

The Dependent of Sheet1 A1 is Sheet2 E4.

[Kenneth Hobs]

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]

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]

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]

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]

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.