vba 在 Excel 中以编程方式选择其他工作表先例或从属

Programmatically select other sheet precedents or dependents in Excel

提问by Mark Hurd

In Excel Ctrl+[or ]will sometimes directly switch to another sheet to show the precedents or dependents in that sheet.

在 Excel Ctrl+ [or]有时会直接切换到另一个工作表以显示该工作表中的先例或依赖项。

I want that programmatically, because I want to get the precedents (or dependents) of a selection of cells.

我希望以编程方式进行，因为我想获得一组单元格的先例（或依赖项）。

Range.Dependentsand Range.Precedentshave other issues, but the solution there does not solve the extra-sheet issue.

Range.Dependents并Range.Precedents有其他问题，但那里的解决方案并没有解决额外的问题。

采纳答案by Mark Hurd

After a fair bit of Googling I found it was solved in 2003.

经过一番谷歌搜索后，我发现它已在2003年解决。

But I used the code from here.

但我使用了这里的代码。

The problem is that Dependentsand Precedentsare Rangeproperties, which can't refer to multiple worksheets.

问题是DependentsandPrecedents是Range属性，不能引用多个工作表。

The solution uses NavigateArrowto locate the cross-sheet 'dents.

该解决方案用于NavigateArrow定位跨板“凹痕”。

Here's my code:

这是我的代码：

Option Explicit

Private Sub GetOffSheetDents(ByVal doPrecedents As Boolean)

Dim c As Range
Dim results As Range
Dim r As Range
Dim sheet As Worksheet
Dim extra As Boolean

For Each c In Application.Intersect(ActiveSheet.UsedRange, Selection)
    Set r = oneCellDependents(c, doPrecedents)
    If Not r Is Nothing Then
        If r.Worksheet Is ActiveSheet Then
            ' skip it
        ElseIf sheet Is Nothing Then
            Set sheet = r.Worksheet
            Include results, r
        ElseIf Not sheet Is r.Worksheet Then
            If Not extra Then
                extra = True
                MsgBox "More than one external sheet in " & IIf(doPrecedents, "Precedents", "Dependents") & ". Only displaying first sheet."
            End If
        Else
            Include results, r
        End If
    End If
Next

If results Is Nothing Then
    Beep
Else
    results.Worksheet.Activate
    results.Select
End If
End Sub

Sub GetOffSheetDependents()

GetOffSheetDents False

End Sub

Sub GetOffSheetPrecedents()

GetOffSheetDents True

End Sub

Private Function Include(ByRef ToUnion As Range, ByVal Value As Range) As Range
If ToUnion Is Nothing Then
    Set ToUnion = Value
Else
    Set ToUnion = Application.Union(ToUnion, Value)
End If
Set Include = ToUnion
End Function

Private Function oneCellDependents(ByVal inRange As Range, Optional doPrecedents As Boolean) As Range

Dim inAddress As String, returnSelection As Range
Dim i As Long, pCount As Long, qCount As Long

If inRange.Cells.Count <> 1 Then Error.Raise 13

Rem remember selection
Set returnSelection = Selection
inAddress = fullAddress(inRange)

Application.ScreenUpdating = False
With inRange
    .ShowPrecedents
    .ShowDependents
    .NavigateArrow doPrecedents, 1
    Do Until fullAddress(ActiveCell) = inAddress
        pCount = pCount + 1
        .NavigateArrow doPrecedents, pCount
        If ActiveSheet.Name <> returnSelection.Parent.Name Then

            Do
                qCount = qCount + 1
                .NavigateArrow doPrecedents, pCount, qCount
                Include oneCellDependents, Selection
                On Error Resume Next
                .NavigateArrow doPrecedents, pCount, qCount + 1
                If Err.Number <> 0 Then _
                    Exit Do
                On Error GoTo 0
            Loop
            On Error GoTo 0
            .NavigateArrow doPrecedents, pCount + 1
        Else
            Include oneCellDependents, Selection
            .NavigateArrow doPrecedents, pCount + 1
        End If
    Loop
    .Parent.ClearArrows
End With

Rem return selection to where it was
With returnSelection
    .Parent.Activate
    .Select
End With
Application.ScreenUpdating = True

End Function

Private Function fullAddress(inRange As Range) As String
With inRange
    fullAddress = .Parent.Name & "!" & .Address
End With
End Function

回答by kaidobor

Mark did some good job, but this macro altogether did not go to 'dents in the same sheet and failed, when there were 'dents from multiple sheets, since the selection cannot be created from multiple sheet cells.

马克做得很好，但是这个宏完全没有去'同一工作表中的凹痕并且失败，当有'来自多个工作表的凹痕时，因为无法从多个工作表单元格创建选择。

I personally needed all this functionality to replace the "Ctrl + [" and "Ctrl + ]" quick shortcut functionality for jumping to precedents and dependents. Unfortunately, these shortcuts are completely unusable on international keyboard, where these square brackets are buried under AltGr (right Alt) combination and Excel does not allow either Ctrl+AltGr+8 and Ctrl+AltGr+8 to give the same result and also there is no way to remap the default shortcuts.

我个人需要所有这些功能来替换“Ctrl + [”和“Ctrl + ]”快速快捷功能，以跳转到先例和依赖项。不幸的是，这些快捷键在国际键盘上完全无法使用，这些方括号被埋在 AltGr（右 Alt）组合下，Excel 不允许 Ctrl+AltGr+8 和 Ctrl+AltGr+8 给出相同的结果，而且还有无法重新映射默认快捷方式。

So I improved the code of Mark slightly to fix these issues and removed the pop-up message from code, since I should know myself if I cannot select all 'dents, but I want the function to work smoothly without me having to click OK all the time. So the function just jumps to the sheet, which is linked first in the formula.

所以我稍微改进了 Mark 的代码来解决这些问题并从代码中删除了弹出消息，因为如果我不能选择所有的“凹痕”，我应该知道自己，但我希望该功能能够顺利运行，而不必单击“全部”时间。因此，该函数只是跳转到公式中最先链接的工作表。

I hope this is useful for others as well.

我希望这对其他人也有用。

The only thing what still bothers me is that while Application.ScreenUpdating = False Avoids jumping around the sheet and workbook, the arrows still keep blinking. Any way to avoid this?

唯一仍然困扰我的是，虽然 Application.ScreenUpdating = False 避免在工作表和工作簿周围跳跃，但箭头仍然保持闪烁。有什么办法可以避免这种情况？

Option Explicit

Private Sub GetOffSheetDents(ByVal doPrecedents As Boolean)
'Main function, calling for separate function to find links to all cells to one of the input cells. Works for finding precedents for a whole selection (group of cells)
'doPrecedents is TRUE, if we are searching for precedents and FALSE, if looking for dependents
Dim InputCell As Range
Dim results As Range
Dim r As Range
Dim sheet As Worksheet

Application.ScreenUpdating = False

For Each InputCell In Application.Intersect(ActiveSheet.UsedRange, Selection)
'Cycle to go over all initially selected cells. If only one cell selected, then happens only once.
    Set r = oneCellDependents(InputCell, doPrecedents)
    ' r is resulting cells from each iteration of input cell to the function.
    If Not r Is Nothing Then      'if there were precedents/dependents
        If sheet Is Nothing Then  'if this is the first time.
            Set sheet = r.Worksheet
            Include results, r
        ElseIf Not sheet Is r.Worksheet Then 'if new precedent/dependent is on another worksheet, don't add to selection (gets lost)
        Else
            Include results, r
        End If
    End If
Next
Application.ScreenUpdating = True

If results Is Nothing Then
    Beep
Else
    results.Worksheet.Activate
    results.Select
End If
End Sub

Sub GetOffSheetDependents()
'Function defines, if we are looking for Dependents (False) or Precedents (True)
GetOffSheetDents False

End Sub

Sub GetOffSheetPrecedents()
'Function defines, if we are looking for Dependents (False) or Precedents (True)
GetOffSheetDents True

End Sub

Private Function Include(ByRef ToUnion As Range, ByVal Value As Range) As Range
If ToUnion Is Nothing Then
    Set ToUnion = Value
    ElseIf Value.Worksheet Is ToUnion.Worksheet Then 'if new precedent/dependent is on the same worksheet, then add to selection
            'if new precedent/dependent is on another worksheet, don't add to selection (gets lost)
        Set ToUnion = Application.Union(ToUnion, Value)
End If
Set Include = ToUnion
End Function

Private Function oneCellDependents(ByVal inRange As Range, Optional doPrecedents As Boolean) As Range
'Function finds dependents for one of the selected cells. Happens only once, if initially only one cell selected.
Dim inAddress As String, returnSelection As Range
Dim i As Long, pCount As Long, qCount As Long
Application.ScreenUpdating = False
If inRange.Cells.Count <> 1 Then Error.Raise 13 'seems to check, that only one cell is handled, but does not seem to be necessary step.

'remember selection
Set returnSelection = Selection ' to keep initial selection for GetOffSheetDents function.
inAddress = fullAddress(inRange) ' takes address of starting cell what is analyzed.
pCount = 1

With inRange   'all functions apply to this initial cell.
    .ShowPrecedents
    .ShowDependents
    .NavigateArrow doPrecedents, 1 ' go to first precedent (if first argument is true)/dependent. But why required?
    Do Until fullAddress(ActiveCell) = inAddress
        .NavigateArrow doPrecedents, pCount 'go to first precedent, then second etc.
        If ActiveSheet.Name <> returnSelection.Parent.Name Then ' checks, if the precedent is NOT on the same sheet

            Do
                qCount = qCount + 1   'qCount follows external references, if arrow is external reference arrow.
                .NavigateArrow doPrecedents, pCount, qCount 'go to first exteranl precedent, then second etc.
                Include oneCellDependents, Selection
                On Error Resume Next
                .NavigateArrow doPrecedents, pCount, qCount + 1 'could remove this step and check for error before Include?
                If Err.Number <> 0 Then Exit Do
                On Error GoTo 0  ' not sure if this is used, since if there is error, then already Exit Do in previous step.
            Loop
            On Error GoTo 0 'not sure, if necessary, since just asked in loop.
        Else  ' if precedent IS ON the same sheet.
            Include oneCellDependents, Selection
        End If
        pCount = pCount + 1
        .NavigateArrow doPrecedents, pCount
    Loop
    .Parent.ClearArrows
End With

'return selection to where it was
With returnSelection
    .Parent.Activate
    .Select
End With

End Function

Private Function fullAddress(inRange As Range) As String
'Function takes a full address with sheet name

With inRange
    fullAddress = .Parent.Name & "!" & .Address
End With
End Function

回答by Jeff1265344

I found kaidobor's version of Mark Hurd's code exactly what I needed. I wrote a wrapper to document all the dependencies in the selected cells and insert them in a new sheet. My code just calls kaidobor's code and records the results.

我发现 kaidobor 版本的 Mark Hurd 代码正是我所需要的。我编写了一个包装器来记录所选单元格中的所有依赖项，并将它们插入到新工作表中。我的代码只是调用kaidobor的代码并记录结果。

My use case: I have a complex spreadsheet (written by someone else) that I need to clean up. I want to delete some sheets that appear unnecessary but want to know where I'll be breaking formulas before deleting the sheets. This will create an index showing all the cells that are referenced in other sheets.

我的用例：我有一个复杂的电子表格（由其他人编写）需要清理。我想删除一些看起来不必要的工作表，但想知道在删除工作表之前我将在哪里破坏公式。这将创建一个索引，显示在其他工作表中引用的所有单元格。

Sub FindDependentsForThisSheet()
' Find all cells in the selection that have dependents on some other sheet
' Calls code by kaidobor
' January 9, 2017
Dim rCurrent As String, strNoDependents As String, strDependents As String, strCurrrentParent As String
Dim aDependents(1000, 4) As String ' Starting sheet, starting cell, referenced sheet, referenced cell
Dim intArrayRows As Long
strNoDependents = "No Dependents" & vbCrLf
strDependents = "Dependents" & vbCrLf
intArrayRows = 0
Application.ScreenUpdating = False

'Step through each cell in the current sheet (for each…)
For Each cell In Selection.Cells
    ' improvement: step through just the cells that are selected in case I know some are not worth bothering with
    Range(cell.Address).Select
    rCurrent = ActiveCell.Address
    strCurrrentParent = ActiveCell.Parent.Name
    'Run GetOffSheetDependents() for each cell
    GetOffSheetDependents
    'GetOffSheetPrecedents
    'When GetOffSheetDependents() is done, if the ActiveCell.Address is not changed,
    'If (rCurrent = ActiveCell.Address And strCurrrentParent = ActiveCell.Parent.Name) Then ' We do care about links on the current sheet
    If (strCurrrentParent = ActiveCell.Parent.Name) Then ' Do not care about links on the current sheet
        'then nothing
        strNoDependents = strNoDependents & ActiveCell.Parent.Name + " - " + ActiveCell.Address & vbCrLf
    Else
        ' Stuff the array
        aDependents(intArrayRows, 0) = strCurrrentParent
        aDependents(intArrayRows, 1) = rCurrent
        aDependents(intArrayRows, 2) = ActiveCell.Parent.Name
        aDependents(intArrayRows, 3) = ActiveCell.Address
        intArrayRows = intArrayRows + 1
        strDependents = strDependents + strCurrrentParent + "!" + rCurrent + " referenced in " + ActiveCell.Parent.Name + "!" + ActiveCell.Address & vbCrLf
        '1 record ActiveCell.Address + parent.
        '2 return to home sheet and
        Sheets(strCurrrentParent).Select
        '3 record the address of the active cell
    End If
    If intArrayRows > 999 Then
        MsgBox "Too many cells, aborting"
        Exit Sub
    End If
Next
'Debug.Print strDependents
'Debug.Print strNoDependents

' Store results in a new sheet
If intArrayRows > 0 Then
    varReturn = NewSheetandPaste(aDependents)
    MsgBox ("Finished looking for dependencies. Created sheet with results. Found this many: " & intArrayRows)
Else
    MsgBox ("Finished looking for dependencies, found none.")
End If
Application.ScreenUpdating = True
End Sub
' ************************************************************************************************

Function NewSheetandPaste(aPasteThis As Variant) '(strSheetName As String)
' Create new sheet and past strDependents
Dim strName As String, strStartSheetName As String, n As Long
'strName = strSheetName + "Dependents"
strStartSheetName = ActiveSheet.Name
strName = strStartSheetName + "Dependents"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = strName
'Sheets("Sheet4").Name = "Sheet1Dependents"
Range("A1").Value = "Dependents from " + strStartSheetName
'ActiveCell.FormulaR1C1 = "Dependents from Sheet1"
'Range("A2").Value = strPasteThis
Range("A2").Value = "Starting Sheet"
Range("B2").Value = "Starting Sheet Cell"
Range("C2").Value = "Dependent Sheet"
Range("D2").Value = "Dependent Sheet Cell"

Range("A3").Select
intLengthArray = UBound(aPasteThis) - LBound(aPasteThis) + 1
n = 0
'For n = 0 To intLengthArray
While aPasteThis(n, 0) <> ""
    ActiveCell.Value = aPasteThis(n, 0)
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Value = aPasteThis(n, 1)
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Value = aPasteThis(n, 2)
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Value = aPasteThis(n, 3)
    ActiveCell.Offset(1, -3).Select
    n = n + 1
Wend

NewSheetandPaste = True
End Function