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
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
Yes. All dependent cells must be on the same worksheet then the that cell is red font color or interior color red?
Can you post an example workbook? Some people confuse dependents with precedents.
i attached the file.
The Dependent of Sheet1 A1 is Sheet2 E4.
Last edited by uktous; 12-16-2013 at 08:35 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
Last edited by Kenneth Hobs; 12-16-2013 at 09:42 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.
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
Perhaps
The .NavigateArrow function always puts all off-sheet precedent/dependents on arrow 1.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