在Excel中以编程方式select其他工作表先例或从属者
在Excel中， Ctrl + [或]有时会直接切换到另一个工作表以显示该工作表中的先例或从属关系。
我想以编程方式，因为我想获得select单元格的先例（或从属）。
Range.Dependents和Range.Precedents有其他问题 ，但是那里的解决scheme并没有解决额外问题。
马克做得不错，但是这个macros并没有在同一张纸上“凹陷”，而是在“多张纸上出现凹痕时失败”，因为select不能由多张纸单元创build。
我个人需要所有这些function来取代“Ctrl + [”和“Ctrl +”）快速快捷function，以跳转到先例和依赖。 不幸的是，这些快捷键在国际键盘上完全无法使用，这些方括号被隐藏在AltGr（右Alt）组合下，Excel不允许Ctrl + AltGr + 8和Ctrl + AltGr + 8给出相同的结果，没有办法重新映射默认快捷方式。
所以我稍微改进了Mark的代码来解决这些问题，并从代码中删除了popup消息，因为我应该知道自己是否无法select所有的凹痕，但是我希望该function能够顺利工作，而不必单击OK时间。 所以函数只是跳转到表单中，该表单在公式中首先链接。
我希望这对其他人也有用。
唯一让我困扰的是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
经过一段时间的search后，我发现它在2003年得到了解决。
但是我使用了这里的代码。
问题是， Dependents和Precedents是Range属性，它不能引用多个工作表。
该解决scheme使用NavigateArrowfind交叉表的凹痕。
这是我的代码：
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
我发现了凯德波的马克·赫德编码正是我所需要的。 我写了一个包装器来logging所选单元格中的所有依赖关系，并将它们插入到一个新表单中。 我的代码只是调用kaidobor的代码并logging结果。
我的用例：我有一个复杂的电子表格（由其他人编写），我需要清理。 我想删除一些看似不必要的表格，但是想要知道在删除表格之前我会破坏公式。 这将创build一个索引，显示其他工作表中引用的所有单元格。
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