这段代码:
- 测试第一张工作表的 A1:A10 中的每个单元格是否直接依赖于第二张工作表(需要进一步细化以测试是否存在其他工作表上的中间参考)
- 如果存在依赖于 sheet2,则将这些单元格着色为红色,否则清除内部格式
设置要测试的区域
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Sheets(1).[a1:a10]
Application.ScreenUpdating = False
For Each rng2 In rng1.Cells
If oneCellsDependents(rng2) Then
rng2.Interior.Color = vbRed
Else
rng2.Interior.Color = xlNone
End If
Next
Application.ScreenUpdating = True
End Sub
依赖查找器
Function oneCellsDependents(rng1 As Range) As Boolean
' 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 Long, iArrowNum As Long
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
rng1.ShowDependents
Set rLast = rng1
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
If oneCellsDependents Then Exit Do
Do
Application.Goto rLast
On Error Resume Next
rng1.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 ActiveCell.Parent.Name = Sheets(2).Name Then
oneCellsDependents = True
Exit Do
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
End Function