method find of object range failed in vba - excel

I have written a code that finds all the dye word and sum all the dye word value.
Here is the code
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = Range("Q10:S61")
Set firstDyeWord = findDyeRange.Find(name)
If firstDyeWord Is Nothing Then
msgbox "nothing found"
Else
firstDyeValue = firstDyeWord.Offset(0, 1).Value
Set secondDyeWord = findDyeRange.FindNext(firstDyeWord)
If secondDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue
Exit Sub
Else
secondDyeValue = secondDyeWord.Offset(0, 1).Value
Set thirdDyeWord = findDyeRange.FindNext(secondDyeWord)
If thirdDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue
Exit Sub
Else
thirdDyeValue = thirdDyeWord.Offset(0, 1).Value
Set fourthDyeWord = findDyeRange.FindNext(thirdDyeWord)
If fourthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue
Exit Sub
Else
fourthDyeValue = fourthDyeWord.Offset(0, 1).Value
Set fifthDyeWord = findDyeRange.FindNext(fourthDyeWord)
If fifthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue
Exit Sub
Else
fifthDyeValue = fifthDyeWord.Offset(0, 1).Value
Set sixthDyeWord = findDyeRange.FindNext(fifthDyeWord)
If sixthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue + fifthDyeValue
Exit Sub
Else
sixthDyeValue = sixthDyeWord.Offset(0, 1).Value
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue + fifthDyeValue + sixthDyeValue
End If
End If
End If
End If
End If
End If
the code runs well. But when I removes the msgbox and set a code then it throws an error.
I want this code
If firstDyeWord Is Nothing Then
Range("A9").value = 7
But it throws error "method find of object range failed in vba"
Help Please!

According to the documentation of the Range.Find method you must at least specify the parameters LookIn, LookAt, SearchOrder and MatchByte when using Find() otherwise it uses what ever was used last by either VBA or the user interface.
Since you cannot know what your users used last in the user interface your search might randomly work and randomly come up with wrong results. Therefore always specify all of these 4 parameters to make it reliable.
Additionally you must specify in which workbook/worksheet your ranges are. Otherwise Excel guesses and it might guess the wrong sheet.
Make sure to declare all your variables properly. I recommend always to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration.
Public Sub Example()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'set your workbook and worksheet!
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = ws.Range("Q10:S61") 'specify in which sheet the range is
Dim firstDyeWord As Range
Set firstDyeWord = findDyeRange.Find(What:=name, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte=False)
If firstDyeWord Is Nothing Then
'dye was NOT found
ws.Range("A9").Value = 7 'specify in which sheet the range is
Else
'do something else if dye was found
End If
End Sub
// Edit (see comment)
If this is used in an event like Worksheet_Change you need to turn off events before writing to a cell. Otherwise this will trigger another event which will trigger another event … and you get stuck in an endless loop of events, which cannot work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'set your workbook and worksheet!
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = ws.Range("Q10:S61") 'specify in which sheet the range is
Dim firstDyeWord As Range
Set firstDyeWord = findDyeRange.Find(What:=name, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte=False)
If firstDyeWord Is Nothing Then
'dye was NOT found
On Error Goto REACTIVATE_EVENTS 'in any case of error reactivate events
Application.EnableEvents = False 'disable events or .Value = 7 triggers another change event.
ws.Range("A9").Value = 7 'specify in which sheet the range is
Application.EnableEvents = True 'make sure you never leave events disabled otherwise they will stay off until you restart Excel.
Else
'do something else if dye was found
End If
Exit Sub
REACTIVATE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext 'show error message if there was an error.
End Sub

Related

Assigning Macro with ParamArray: Formula is Too Complex to add to the Object

I have a macro (below) that inserts a new row into an un-defined number of Named ranges using ParamArray, it works fine except for when I try to assign the macro with more than 5-6 arguments I get a message box that says "Formula Too Complex to Assign To Object" (see picture above)
(see assignment string below)
'InsertNewRow "ServiceCrewDay_EmployeeList", "SAP_SCD_InPool", "SAP_SCD_OutPool", "SAP_SCD_SecondaryIn", "SAP_SCD_SecondaryOut", "SAP_SCD_ORD","SAP_SCD_THF","SAP_SCD_LH", "SAP_SCD_LH"'
Macro:
Sub InsertNewRow(ParamArray args() As Variant)
Dim ans: ans = MsgBox("WARNING: " & vbNewLine _
& "Action Cannot be undone!" & vbNewLine & "Continue?", vbYesNo, "Warning!")
If ans = vbNo Then: Exit Sub
Call HaltOperations
Call ActiveSheet.Unprotect()
Call Sheets("SAP Timesheet").Unprotect()
On Error GoTo OnError_Exit
'Loop and Check All Named Ranges Exist Before Proceeding
For Each a In args
If RangeExists(a) = False Then
MsgBox ("Named Range: " & a & " Not Defined!" & vbNewLine & "Operation Cancelled")
Exit Sub
End If
Next a
Dim rng As Range
'ADD ROW TO EACH NAMED INPUT RANGE
For Each a In args
Set rng = Range(a)
With rng
.Rows(.Rows.count).EntireRow.Insert
.Rows(.Rows.count - 2).EntireRow.Copy
.Rows(.Rows.count - 1).EntireRow.PasteSpecial (xlPasteFormulasAndNumberFormats)
On Error Resume Next: .Rows(.Rows.count - 1).EntireRow.PasteSpecial (xlPasteFormats)
End With
Next a
On Error GoTo OnError_Exit
'ADJUST HEIRACHY NUMBERS ON FIRST INPUT RANGE (MANNING TAB)
Set rng = Range(args(0))
Dim col As Integer
col = rng.Column
Cells(rng.Row + rng.Rows.count - 2, col).Offset(0, -1).Value _
= Cells(rng.Row + rng.Rows.count - 3, col).Offset(0, -1).Value + 1
Cells(rng.Row + rng.Rows.count - 1, col).Offset(0, -1).Value _
= Cells(rng.Row + rng.Rows.count - 3, col).Offset(0, -1).Value + 2
Call ResumeOperations
Application.CutCopyMode = False
Call ActiveSheet.Protect()
Call Sheets("SAP Timesheet").Protect()
Exit Sub
OnError_Exit:
Call ResumeOperations
Application.CutCopyMode = False
Call ActiveSheet.Protect()
Call Sheets("SAP Timesheet").Protect()
End Sub
Private Function RangeExists(rng As Variant) As Boolean
Dim Test As Range
On Error Resume Next
Set Test = Range(rng)
RangeExists = Err.Number = 0
End Function
Private Sub HaltOperations()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
End Sub
Private Sub ResumeOperations()
ResumeOps:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
The Macro itself runs as expected it's just the assigning the named ranges that is causing the issue.
is there a better way to do this?
or is there a way to get around the Formula is too complex method?
and if there is will that need to be done on all end user pc's or just on mine and the settings will carry over?
What I have thought about doing was just taking in 2 Named ranges and then for the following ranges Just offsetting those by the Row Count of the previous range so if Range2 = Sheets().Range("A1:A10") then Range3 = Range2.Offset(Range2.Rows.Count,0) then the assingment input would only need to be Range1 as string, Range2 as string, NumberOfExtraRanges as integer the reason I need atleast two ranges is because every range after range 1 is on a different tab and is essentially a raw data version of all pay info hours etc. in the first tab which will be Range1_EmployeeList
which I will play around with while I wait for a response.
TIA
Not a Complete answer but I did find that inside the ParamArray I could just assign One Input Range using a , to seperate each defined range. I haven't tested the limitations doing it this way but it does seem to atleast let me use a few extra inputs.
Example (Not Working):
Note: Each Defined Range is a Separate Input
'InsertNewRow "ServiceCrewDay_EmployeeList", "SAP_SCD_InPool" ," SAP_SCD_OutPool","SAP_SCD_SecondaryIn", "SAP_SCD_SecondaryOut"'
Example (Working):
Note Each Defined Range is passed as 1 input
'InsertNewRow "ServiceCrewDay_EmployeeList", "SAP_SCD_InPool, SAP_SCD_OutPool,SAP_SCD_SecondaryIn,SAP_SCD_SecondaryOut"'

Excel VBA - Range(Find().Adress).Row

I have googled and struggled with this for hours now.
I have a Control workbook, that pulls data from a varied amount of other workbooks (the Control workbook also creates the other workbooks and saves the names and dir of said workbooks so that they can be called later)
This piece of code is the problem.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Declare_Sheets
Dim SearchresultROW
Dim Searchresult As String
Dim complexrow As Integer
Dim CurrSheet As Worksheet
Dim Stype As String
Dim startROW As Integer
Dim endROW As Integer, SearchCOL As Integer, OffROW As Integer
Dim PDATArange As Range, CDATArange As Range
Dim Dateyear, Datemonth, datetest As String
Stype = WSRD.Range("B11")
'Find complex to work with
complexrow = WSSS.Range("F7")
WSSS.Activate
SearchresultROW = Range(Cells(7, 15), Cells(complexrow, 15).Find(Callsheet).Address).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The below code is the problem extract
complexrow = WSSS.Range("F7")
WSSS.Activate
SearchresultROW = Range(Cells(7, 15), Cells(complexrow, 15).Find(Callsheet).Address).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
1st problem
I cant get the find() to work without activating worksheet - WSSS
Declare_Sheets gets run at the start which declares WSSS, this works everywhere else in my code, but not with this find().
2nd problem
The code below compiles and finishes, BUT - It does not return the correct data.
This code calls starts the macro
Cancel = True
Dim Calsheet As String
If Target.Column <> 1 Then Exit Sub
Calsheet = Target.Value
Call Call_Readings(Calsheet)
End Sub
There are currently 2 possibilities
I double click on Casper Tcomp 4.
Callsheet = "Casper Tcomp 4" - Which is correct (target of the double click)
Complexrow = "9" - Which is correct (this will increment as new sheets are added)
SearchresultROW = "7" - This is wrong, it should be 8
I have tried adding LookAt:=xlWhole and LookIn:-xlValues, doesnt change a thing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Declare_Sheets
Dim SearchresultROW
Dim Searchresult As String
Dim complexrow As Integer
Dim CurrSheet As Worksheet
Dim Stype As String
Dim FindResult As Range
Dim startROW As Integer
Dim endROW As Integer, SearchCOL As Integer, OffROW As Integer
Dim PDATArange As Range, CDATArange As Range
Dim Dateyear, Datemonth, datetest As String
Stype = WSRD.Range("B11")
'Find complex to work with
complexrow = WSSS.Range("F7")
On Error Resume Next 'next line will error if nothing is found
Set FindResult = WSSS.Range(WSSS.Cells(7, 15), WSSS.Cells(complexrow, 15)).Find(What:=Callsheet, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=False)
On Error GoTo 0 'always re-activate error reporting!
If Not FindResult Is Nothing Then 'check if find was successful
SearchresultROW = FindResult.Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Else 'if nothing was found show message
MsgBox "NO WB FOUND.", vbCritical
End If
This solved the problem, thanks for the assistance Pᴇʜ
Your code without .Activate would look something like below. Note that every Range, Cells, Rows or Columns object needs to be referenced with the correct Workbook/Worksheet:
complexrow = WSSS.Range("F7")
'try to find something
Dim FindResult As Range
On Error Resume Next 'next line will error if nothing is found
Set FindResult = WSSS.Cells(complexrow, 15).Find(What:=Callsheet, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=False)
On Error GoTo 0 'always re-activate error reporting!
If Not FindResult Is Nothing Then 'check if find was successful
SearchresultROW = WSSS.Range(WSSS.Cells(7, 15), FindResult).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Else 'if nothing was found show message
MsgBox "nothing found.", vbCritical
End If
Note that if using the Range.Find method you need to check if something was found before you can use the result of Find. Otherwise it will throw an error. Also note that the documentation of Find says that …
The settings for LookIn, LookAt, SearchOrder, and MatchByte are saved each time you use this method.
So if you don't define them each time using Find it will use whatever was used last by either VBA or the user interface. Since you have no control about what was used last by the user interface I highly recomment to define them everytime using Find or you will get random results.
Also note that Callsheet is not defined in your code yet, so check that.

Insert a row in a data table at a special position under conditions

I've been working on the development of a tool that is supposed to help me manage some projects.
I have a table of data called t_data.
This data table contains every projects. Each project is devided on quarters (Q1 2019, Q2 2019, Q3 2019, etc.). Each quarter is devided on deliverables (not always the same number of deliverables so not the same amount of rows for each quarter).
I have a form in another sheet (name of the sheet: MENU!) that permits to add a new deliverable to a Quarter of a project, and where I put the necessary inputs so that I can find the good raw where I should insert my deliverable. The inputs are the project's name (in MENU!D10) and the quarter concerned by the deliverable (in MENU!D12).
Here is my code :
Sub ajouter_un_livrable()
'
' ajouter_un_livrable Macro
' Ajoute un livrable en fonction de son challenge et de son trimestre.
'
Dim result As Variant
match_formula = "EQUIV(1;(t_data[Associated_challenge] = MENU!$D$10)*(t_data[Associated_quarter] = MENU!$D$12);0)"
result = Evaluate(match_formula)
numero_ligne = CLng(result)
numero_ligne = numero_ligne - 2003
Worksheets("TRT RTI Challenges").Rows(numero_ligne).insert
'Set datasheet = Worksheets("TRT RTI Challenges").ListObjects("t_data")
'With datasheet
'.Cells(numero_ligne, 10).Select
'Selection.ListObject.ListRows.Add (numero_ligne)
'Set myNewDeliverable = .ListRows.Add(numero_ligne)
'End With
'
End Sub
You'll notice I'm french ehe
numero_ligne sounds to return the number 2015 because I have an error 2015... great !
I don't know how to manage the EVALUATE. How can I take its value into a variable ? I've tried a lot of things, consult a lot of forums but nothing's working :'(
Do you have an idea of how I could solve my issue ?
Thanks a lot to the one or those that will help me or at least try. :D
I believe something like this should work for you:
Sub ajouter_un_livrable()
Dim wsInput As Worksheet
Dim rProjects As Range
Dim rQuarters As Range
Dim rFound As Range
Dim vProject As Variant
Dim vQuarter As Variant
Dim sProjectCell As String
Dim sQuarterCell As String
Dim sFirst As String
Dim bMatch As Boolean
sProjectCell = "D10"
sQuarterCell = "D12"
On Error Resume Next
Set wsInput = ActiveWorkbook.Worksheets("MENU")
Set rProjects = Range("t_Data").ListObject.ListColumns("Associated_challenge").DataBodyRange
Set rQuarters = Range("t_Data").ListObject.ListColumns("Associated_quarter").DataBodyRange
On Error GoTo 0
If wsInput Is Nothing Or rProjects Is Nothing Or rQuarters Is Nothing Then
MsgBox "Unable to find a worksheet named 'MENU' or unable to find a table named 't_Data' in this workbook.", , "Error"
Exit Sub
End If
vProject = wsInput.Range(sProjectCell).Value
vQuarter = wsInput.Range(sQuarterCell).Value
If Len(vProject) = 0 Then
wsInput.Select
wsInput.Range(sProjectCell).Select
MsgBox "Input for Project is required.", , "Error"
Exit Sub
ElseIf Len(vQuarter) = 0 Then
wsInput.Select
wsInput.Range(sQuarterCell).Select
MsgBox "Input for Quarter is required.", , "Error"
Exit Sub 'No data
End If
bMatch = False
Set rFound = rProjects.Find(vProject, rProjects.Cells(rProjects.Cells.Count), xlValues, xlWhole, , xlNext, False)
If Not rFound Is Nothing Then
sFirst = rFound.Address
Do
If LCase(rQuarters.Worksheet.Cells(rFound.Row, rQuarters.Column).Value) = LCase(vQuarter) Then
bMatch = True
Exit Do
End If
Set rFound = rProjects.FindNext(rFound)
Loop While rFound.Address <> sFirst
If bMatch Then
rFound.EntireRow.Insert
'Row inserted, proceed with what you want to do with the inserted row here
End If
Else
MsgBox "Unable to find matching row for :" & Chr(10) & "Project: " & vProject & Chr(10) & "Quarter: " & vQuarter, , "Error"
End If
End Sub

Runtime Error 13 - Mismatch

I'm new at VBA coding and working on a match code. The code is working just fine when I run the code in "Data sheet" (the sheet were all my data is and were the match has to be found), but when i'm run the code on the frontpage (Sheet 1 with userforms) the code is debuggen and says "Runtime Error 13". Can anybody tell what the problem is?
And can anybody tell me why my "If isError" doesn't work?
Thanks in advance!
Br
'Find SKU and Test number
Dim icol As Integer
Sheet13.Range("XFD2") = UserForm2.ComboBox1.Value 'Sættes = ComboBox1.value
Sheet13.Range("XFD3") = UserForm2.ComboBox2.Value 'Sættes = ComboBox2.value
icol = [Sheet13.MATCH(XFD2&XFD3,A:A&Q:Q,0)] 'Match af værdien for vores SKU og test nr
With ThisWorkbook.Worksheets("Data sheet")
'If SKU or Test number not found, then messagebox
If IsError("A:A") Then MsgBox "SKU not found": Exit Sub
If IsError("Q:Q") Then MsgBox "Test number not found": Exit Sub
'Add test result/next step and comment
.Cells(icol, 30).Value = Me.ComboBox3.Value
.Cells(icol, 30 + 1).Value = Me.Comments_To_Result.Value
End With
End If
Set objFSO = Nothing
Set openDialog = Nothing
Range("XFD2").Clear
Range("XFD3").Clear
icol should be like this:
icol = Application.match(arg1, arg2, arg3)
See the samples in MSDN:
var = Application.Match(Cells(iRow, 1).Value, Worksheets(iSheet).Columns(1), 0)
Concerning If IsError("A:A") Then MsgBox "SKU not found": Exit Sub, you are doing it wrongly. I assume, that you want to loop through all the cells in the first column and to get whether one of them is an error. You need a loop for this. This is a really simple one, but you should implement it somehow in your code:
Option Explicit
Public Sub TestMe()
Dim rng As Range
For Each rng In Range("A:A")
If IsError(rng) Then Debug.Print rng.Address
Next rng
End Sub

Tracing precedents in external spreadsheets using Excel VBA

I'm currently trying to trace the dependencies of a complex set of Excel spreadsheets. My ideal end goal would be a tree structure, starting with my first spreadsheet. However, I don't want to include all of the dependencies of the child spreadsheets, just the ones of the cells referenced by the original spreadsheet. For example:
In cell A1 of my first workbook:
somebook.xls!Sheet1!C2
I want to look at cell C2 in sheet 1 of somebook.xls for its (external) dependencies, and then recurse.
At the moment I'm using LinkInfo to get a list of external dependencies, searching using Find, and I'm struggling with vbscript's primitive regex capabilities to try and extract the address out of the cells I find. This is not a brilliant way of doing things.
Does anyone know if Excel will tell you which cells in an external spreadsheet are being referenced? If not, any other tools that might help?
Thanks.
This answer is based off Bill Manville's macro from many years back. The macro still works, but I broke it out into functions allowing for more flexibility and reusability. The main addition by me is the ability to find external dependencies only, and the extension to both precedents and dependents. I also added a call to a custom macro called unhideAll; this was necessary for me as dependencies were not being found in hidden worksheets.
'Module for examining depedencies to/from a sheet from/to other sheets
Option Explicit
Sub showExternalDependents()
Dim deps As Collection
Set deps = findExternalDependents(ActiveCell)
Call showDents(deps, True, "External Dependents: ")
End Sub
Sub showExternalPrecedents()
Dim precs As Collection
Set precs = findExternalPrecedents(ActiveCell)
Call showDents(precs, True, "External Precedents: ")
End Sub
'external determines whether or not to print out the absolute address including workbook & worksheet
Sub showDents(dents As Collection, external As Boolean, header As String)
Dim dent As Variant
Dim stMsg As String
stMsg = ""
For Each dent In dents
stMsg = stMsg & vbNewLine & dent.Address(external:=external)
Next dent
MsgBox header & stMsg
End Sub
Function findPrecedents(rng As Range) As Collection
Set findPrecedents = findDents(rng, True)
End Function
Function findDependents(rng As Range) As Collection
Set findDependents = findDents(rng, False)
End Function
Function findExternalPrecedents(rng As Range) As Collection
Set findExternalPrecedents = findExternalDents(rng, True)
End Function
Function findExternalDependents(rng As Range) As Collection
Set findExternalDependents = findExternalDents(rng, False)
End Function
'Gives back only the dependencies that are not on the same sheet as rng
Function findExternalDents(rng As Range, precDir As Boolean) As Collection
Dim dents As New Collection
Dim dent As Range
Dim d As Variant
Dim ws As Worksheet
Set ws = rng.Worksheet
For Each d In findDents(rng, precDir)
Set dent = d
With dent
If Not (.Worksheet.Name = ws.Name And .Worksheet.Parent.Name = ws.Parent.Name) Then _
dents.Add Item:=dent
End With
Next d
Set findExternalDents = dents
End Function
'this procedure finds the cells which are the direct precedents/dependents of the active cell
'If precDir is true, then we look for precedents, else we look for dependents
Function findDents(rng As Range, precDir As Boolean) As Collection
'Need to unhide sheets for external dependencies or the navigate arrow won't work
Call mUnhideAll
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim dents As New Collection
Dim bNewArrow As Boolean
'Appliciation.ScreenUpdating = False
If precDir Then
ActiveCell.showPrecedents
Else
ActiveCell.ShowDependents
End If
Set rLast = rng
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=precDir, 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
dents.Add Item:=Selection
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
Set findDents = dents
End Function
Sub mUnhideAll()
'
' mUnhideAll Macro
'
' Unhide All
Dim ws As Worksheet
For Each ws In Worksheets
ws.Visible = True
Next
'Sheets("Sprint Schedule Worksheet").Visible = False
End Sub
Excel's built in support, as you're finding, is limited and can be extremely frustrating.
In my experience, I've found a couple of tools from http://www.aivosto.com/ to be useful; Visustin v6 is especially useful for code related auditting/processing.
Here's a simpler version of Colm Bhandal's findDents and findExternalDents. It assumes all worksheets were made visible and arrows were cleared before use.
Function findDents(rCell As Range, bPrec As Boolean) As Collection
'Return all direct precedents (bPrec=True) or dependents (bPrec=False) of rCell
Dim sAddr As String, nLink As Integer, nArrow As Integer
Const bAbs As Boolean = False, bExt As Boolean = True
Set findDents = New Collection
If bPrec Then
rCell.showPrecedents ' even if rCell has no formula
Else
rCell.showDependents
End If
On Error Resume Next ' ignore errors
sAddr = rCell.Address(bAbs, bAbs, xlA1, bExt)
nArrow = 1
Do
nLink = 1
Do
rCell.NavigateArrow bPrec, nArrow, nLink
If ActiveCell.Address(bAbs, bAbs, xlA1, bExt) = sAddr Then Exit Do
findDents.Add Selection ' possibly more than one cell
nLink = nLink + 1
Loop
If nLink = 1 Then Exit Do
nArrow = nArrow + 1
Loop
On Error GoTo 0
If bPrec Then
rCell.showPrecedents Remove:=True
Else
rCell.showDependents Remove:=True
End If
End Function
Function findExternalDents(rCell As Range, bPrec As Boolean) As Collection
'Return ...Dents that are NOT in the same workbook and worksheet as rCell
Dim rDent As Range, wsName As String, wbName As String
With rCell.Worksheet: wsName = .Name: wbName = .Parent.Name: End With
Set findExternalDents = New Collection
For Each rDent In findDents(rCell, bPrec)
If rDent.Worksheet.Name <> wsName Or rDent.Worksheet.Parent.Name <> wbName Then findExternalDents.Add Item:=rDent
Next rDent
End Function
You might want to modify this to use a SortedList instead of a Collection. In that case, change
findDents.Add Selection
to
findDents.Add Selection.Address(bAbs, bAbs, xlA1, bExt), Null

Resources