excel - Excel で他のシートの参照元または依存関係をプログラムで選択する

Question

Excel Ctrl+ [orでは]、別のシートに直接切り替えて、そのシートの前例または依存関係を表示することがあります。

選択したセルの先例 (または依存関係) を取得したいので、プログラムでそれが必要です。

Range.Dependents他にRange.Precedentsも問題がありますが、そこの解決策では余分なシートの問題は解決しません。

Answer 1

マークは良い仕事をしましたが、複数のシート セルから選択を作成することはできないため、複数のシートからのへこみがあった場合、このマクロはまったく同じシートのへこみには行きませんでした。

個人的には、前例と依存関係にジャンプするための「Ctrl + [」および「Ctrl + ]」クイック ショートカット機能を置き換えるために、このすべての機能が必要でした。残念ながら、これらのショートカットは、これらの角括弧が AltGr (右 Alt) の組み合わせの下に埋もれている国際キーボードでは完全に使用できず、Excel では Ctrl+AltGr+8 と Ctrl+AltGr+8 のどちらでも同じ結果が得られず、デフォルトのショートカットを再マップする方法はありません。

そこで、これらの問題を修正するために Mark のコードを少し改良し、コードからポップアップ メッセージを削除しました。時間。したがって、関数は数式で最初にリンクされているシートにジャンプするだけです。

これが他の人にも役立つことを願っています。

まだ気になる唯一のことは、 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

Answer 2

かなりのグーグル検索の後、2003年に解決されたことがわかりました。

しかし、私はhereのコードを使用しました。

問題は、DependentsとPrecedentsがRangeプロパティであり、複数のワークシートを参照できないことです。

このソリューションではNavigateArrow、クロスシートの「へこみ」を特定するために使用します。

これが私のコードです：

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