递归VBA先例 [英] Recursive VBA Precedents

问题描述

我有一个excel电子表格，有很多公式和数据，我跟踪。我有一个小宏，可以找到所选单元格的前缀，但是id要使宏递归，以便我可以找到所有的先例。例如，将焦点设置到单元格并运行此功能将突出显示单元格，然后突出显示单元格的先例，然后突出显示单元格的先例，然后突出显示先例...

目前我遇到的问题是我不知道逃生情况应该如何。我已经遇到了一些无限循环的问题，并不熟悉递归，足以找出一个坚实的解决方案。

以下是我正在使用的一些代码（正确的）找到先例：

  Sub FindClosedWbReferences（inRange As Range）
 Rem填充集合从公式String 
 Dim testString As String，returnStr As String，remnantStr As String 
 testString = inRange.Formula 
 testString = RemoveTextInDoubleQuotes（testString）：Rem新行
设置ClosedWbRefs =新集合
 Do 
 returnStr = NextClosedWbRefStr（testString，remnantStr）
 ClosedWbRefs.Add Item：= returnStr，Key：= CStr（ClosedWbRefs.count）
 testString = remnantStr 
 inRange 。选择
 inRange.Interior.ColorIndex = 36 
 
循环直到returnStr = vbNullString 
 
 ClosedWbRefs.Remove ClosedWbRefs.count 
 End Sub 
  

，这是从一个主要功能看起来类似于：

 如果homeCell.HasFormula然后
设置OtherWbRefs =新集合：CountOfClosedWb = 0 
设置SameWbOtherSheetRefs =新集合
设置SameWbSameSheetRefs =新集合
 
 Rem从公式String查找封闭的先例
调用FindClosedWbReferences（homeCell）
  

任何帮助都不胜感激。谢谢

解决方案

正如我在上面的评论中所提到的，这个例子将在同一张表中为先例工作。这将为您开启其他工作表中的先例。

我们的Excel文件看起来像这样（最终提到的示例文件链接）

 单元格A6具有以下公式：= B6 
单元格B6具有以下公式：= C5 + C7 
单元格C5具有以下公式：= D3 + D4 + D5 
单元格C7具有以下公式：= D7 + D8 + D9 
'
'等等。单元格D4，D5，D8，D9，F3，G3，F9 
'G9，G4：I4，G10：I10没有任何公式
  

我从下载示例文件修补。运行宏

如果您希望您可以为G4创建更多先例：I4，G10 ：I10并测试：）

I have an excel spreadsheet with quite a few formulas and data that I keep track of. I have a small macro that will find the Precedents for a selected cell however id like to make the macro recursive so that I can find all of the precedents. Eg Setting focus to a cell and running this function will highlight the cell and then highlight the precedents of the cell, then highlight the precedents of those cells, then highlight the precedents...

The problem I am having at the moment is I am not sure what the escape condition should be. I have ran into a few infinite loop problems and am not familiar with recursion enough to figure out a solid solution.

Below is some code that I am using to (correctly) find the inital precedents:

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

and this is called from a main function that looks similar to:

 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)

Any help is appreciated. Thanks

解决方案

As mentioned in my comments above, here is an example which will work for precedents in the same sheet. This will give you a start for finding precedents in other sheets as well.

Let's say, our Excel File looks like this (Sample File link mentioned in the end).

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  

I picked up the code from here and modified it further to suit my needs.

See this code

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

Output

Sample File

You can download the sample file from HERE to tinker with. Run the macro Sheet1.Sample()

If you want you can create further precedents for G4:I4, G10:I10 and test it :)

这篇关于递归VBA先例的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！