9

我有一个 Excel 电子表格，里面有很多我跟踪的公式和数据。我有一个小宏，可以找到选定单元格的先例，但是我希望使宏递归，以便我可以找到所有先例。例如，将焦点设置到一个单元格并运行此函数将突出显示该单元格，然后突出显示该单元格的先例，然后突出显示这些单元格的先例，然后突出显示该先例......

我目前遇到的问题是我不确定逃生条件应该是什么。我遇到了一些无限循环问题，并且对递归不够熟悉，无法找到可靠的解决方案。

下面是我用来（正确）找到初始先例的一些代码：

Sub FindClosedWbReferences(inRange As Range)
Rem fills the collection With closed precedents parsed from the formula String
Dim testString As String, returnStr As String, remnantStr As String
testString = inRange.Formula
testString = RemoveTextInDoubleQuotes(testString): Rem New line
Set ClosedWbRefs = New Collection
Do
    returnStr = NextClosedWbRefStr(testString, remnantStr)
    ClosedWbRefs.Add Item:=returnStr, Key:=CStr(ClosedWbRefs.count)
    testString = remnantStr
    inRange.Select
    inRange.Interior.ColorIndex = 36

Loop Until returnStr = vbNullString

ClosedWbRefs.Remove ClosedWbRefs.count
End Sub

这是从一个类似于以下内容的主函数调用的：

 If homeCell.HasFormula Then
    Set OtherWbRefs = New Collection: CountOfClosedWb = 0
    Set SameWbOtherSheetRefs = New Collection
    Set SameWbSameSheetRefs = New Collection

    Rem find closed precedents from formula String
    Call FindClosedWbReferences(homeCell)

任何帮助表示赞赏。谢谢

4

1 回答 1

2

正如我在上面的评论中提到的，这是一个适用于同一张表中的先例的示例。这也将使您开始在其他工作表中寻找先例。

比方说，我们的 Excel 文件看起来像这样（最后提到的示例文件链接）。

在此处输入图像描述

Cell A6 has the formula : =B6
Cell B6 has the formula : =C5+C7
Cell C5 has the formula : =D3+D4+D5
Cell C7 has the formula : =D7+D8+D9
'
' And so on. Cells, D4, D5, D8, D9, F3, G3, F9
' G9, G4:I4, G10:I10 do not have any formulas

我从这里获取代码并进一步修改以适应我的需要。

看到这个代码

Dim rw As Long, col As Long
Dim ws As Worksheet
Dim fRange As Range

Sub Sample()
    Set ws = ThisWorkbook.Sheets("Sheet1")

    '~~> Clear cell for output
    ws.Rows("20:" & ws.Rows.Count).Clear

    '~~> Select First Cell
    Set fRange = ws.Range("A6")

    '~~> Set Row for Writing
    rw = 20

    FindPrecedents fRange
End Sub

Sub FindPrecedents(Rng As Range)
    ' written by Bill Manville
    ' With edits from PaulS
    ' With further edits by Me 14 Sept 2013
    ' 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
    Rng.ShowPrecedents
    Set rLast = Rng
    iArrowNum = 1
    iLinkNum = 1
    bNewArrow = True

    col = 1

    ws.Cells(rw, col).Value = Rng.Address

    col = col + 1

    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

            ws.Cells(rw, col).Value = Selection.Address
            col = col + 1

            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

    '~~> Write Output
    If Len(Trim(ws.Cells(rw, 2).Value)) <> 0 Then
        With ws
            '~~> Find Last column in that row
            lcol = .Cells(rw, .Columns.Count).End(xlToLeft).Column

            j = rw + 1

            For i = 2 To lcol
                .Cells(j, 1).Value = .Cells(rw, i)
                j = j + 1
            Next i
        End With
    End If

    rw = rw + 1

    '~~> Here is where I am looping again
    If Len(Trim(ws.Cells(rw, 1).Value)) <> 0 Then
        FindPrecedents Range(ws.Cells(rw, 1).Value)
    End If
End Sub

输出

在此处输入图像描述

示例文件

您可以从这里下载示例文件进行修改。运行宏Sheet1.Sample()

如果您愿意，您可以为 G4:I4、G10:I10 创建更多先例并对其进行测试:)

于 2013-09-14T04:38:44.500 回答