I don't know if this is any use to you, but a teacher friend of mine asked me for some code that would do more or less the same thing as you are asking.
The trick to those Workbook and Worksheet names which contain operator characters is that they'll always be bound by an inverted comma. So we can temporarily remove those items before identifying genuine operators.
There'll doubtless be an easier and quicker way to do it, but in the shortness of time, this is what I came up with for my friend:
Option Explicit
Public Function RangesInFormula(target As Range) As Variant
Dim str As String
Dim item As Variant, items As Variant
Dim addr As String, result As String
'Sense checking
If target.Cells.Count <> 1 Then
RangesInFormula = CVErr(xlErrRef)
Exit Function
End If
If Not target.HasFormula Then Exit Function
'Split formula into array.
items = SplitFormulaByOperators(target)
'Try to grab an address from each formula item.
For Each item In items
If Len(CStr(item)) > 0 Then
addr = RangeToString(CStr(item))
If Len(addr) > 0 Then
If Len(result) > 0 Then result = result & "|"
result = result & addr
End If
End If
Next
'Return the addresses if there are any.
If Len(result) > 0 Then
RangesInFormula = result
End If
End Function
Private Function RemoveTextBetween(startChar As String, endChar As String, sourceText As String) As String
Dim startPt As Long, endPt As Long
Dim tmp As String
tmp = sourceText
Do While True
endPt = InStr(tmp, endChar)
If startChar = endChar Then
endPt = InStr(endPt + 1, tmp, endChar)
End If
If endPt = 0 Then Exit Do
startPt = InStrRev(tmp, startChar, endPt - 1)
If startPt = 0 Then Exit Do
tmp = Left(tmp, startPt - 1) & Right(tmp, Len(tmp) - endPt)
Loop
RemoveTextBetween = tmp
End Function
Private Function SplitFormulaByOperators(target As Range) As Variant
Const OPERATORS = "+|-|*|/|%|^|>=|<=|<>|=|>|<|&|(|)"
Dim ws As Worksheet
Dim opr As Variant, ex As Variant
Dim tmp As String
Dim extractedList As Collection
Dim extracted(1) As String
Dim oprs() As String, result() As String
Dim i As Long
'Convert constant to array.
oprs = Split(OPERATORS, "|")
'Remove text between quotes
tmp = target.formula
tmp = RemoveTextBetween("""", """", tmp)
'Temporarily extract workbook and sheet names which have operators in them.
'They can be identified by bounding inverted commas.
Set extractedList = New Collection
Do While True
extracted(0) = ExtractTextBetween("'", "'", tmp, excludeMarkers:=False)
If Len(extracted(0)) = 0 Then Exit Do
extracted(1) = "|ex" & extractedList.Count & "|"
ex = Empty: On Error Resume Next
ex = extractedList(extracted(0)): On Error GoTo 0
If IsEmpty(ex) Then
extractedList.Add extracted, extracted(0)
tmp = Replace(tmp, extracted(0), extracted(1))
End If
Loop
'Replace the operators
For Each opr In oprs
tmp = Replace(tmp, opr, "|op|")
Next
result = Split(tmp, "|op|")
'Trim whitespace and commas.
For i = LBound(result) To UBound(result)
result(i) = TrimWhitespace(result(i), &H2C)
'Convert back to the extracted values.
For Each ex In extractedList
result(i) = Replace(result(i), ex(1), ex(0))
Next
Next
'Return the array.
SplitFormulaByOperators = result
End Function
Private Function ExtractTextBetween( _
startChar As String, _
endChar As String, _
sourceText As String, _
Optional acceptStartOfStringToEndChar As Boolean = False, _
Optional acceptStartCharToEndOfString As Boolean = False, _
Optional excludeMarkers As Boolean = True) As String
Dim i As Long, startPt As Long, endPt As Long
Dim tmp As String
For i = 1 To Len(sourceText)
tmp = Mid(sourceText, i, Len(startChar))
If startPt = 0 Then
If tmp = startChar Then
startPt = i
End If
Else
If tmp = endChar Then
endPt = i + Len(endChar) - 1
If excludeMarkers Then
startPt = startPt + Len(startChar)
endPt = endPt - Len(endChar)
End If
tmp = Mid(sourceText, startPt, endPt - startPt + 1)
ExtractTextBetween = tmp
Exit Function
End If
End If
Next
If startPt > 0 And endPt = 0 And acceptStartCharToEndOfString Then
If excludeMarkers Then
startPt = startPt + Len(startChar)
End If
tmp = Right(sourceText, Len(sourceText) - startPt + 1)
ExtractTextBetween = tmp
Exit Function
End If
If endPt > 0 And startPt = 0 And acceptStartOfStringToEndChar Then
If excludeMarkers Then
endPt = endPt - Len(endChar)
End If
tmp = Left(sourceText, endPt)
ExtractTextBetween = tmp
Exit Function
End If
End Function
Private Function RangeToString(addr As String) As String
Dim rng As Range
On Error Resume Next
Set rng = Evaluate(addr)
On Error GoTo 0
If rng Is Nothing Then Exit Function
'We have a range, so the address can be returned as valid reference.
RangeToString = addr
End Function
Private Function TrimWhitespace(txt As String, ParamArray additionals() As Variant) As String
Dim i As Long, j As Long, c As Long
Dim startPos As Long, endPos As Long
Dim whitespaces As Variant
Dim isWhitespace As Boolean
' List of whitespace characters.
whitespaces = Array( _
&H9, &HA, &HB, &HC, &HD, &H20, &H85, &HA0, _
&H1680, &H2000, &H2001, &H2002, &H2003, &H2004, &H2005, &H2006, _
&H2007, &H2008, &H2009, &H200A, &H2028, &H2029, &H202F, &H205F, _
&H3000, &H180E, &H200B, &H200C, &H200D, &H2060, &HFEFF)
' Find the first non-whitespace.
For i = 1 To Len(txt)
c = Asc(Mid(txt, i, 1))
isWhitespace = False
For j = LBound(whitespaces) To UBound(whitespaces)
If c = whitespaces(j) Then
isWhitespace = True
Exit For
End If
Next
For j = LBound(additionals) To UBound(additionals)
If c = additionals(j) Then
isWhitespace = True
Exit For
End If
Next
If Not isWhitespace Then
startPos = i
Exit For
End If
Next
' If there's no start position, return an empty string.
If startPos = 0 Then Exit Function
' Find the last non-whitespace.
For i = Len(txt) To startPos Step -1
c = Asc(Mid(txt, i, 1))
isWhitespace = False
For j = LBound(whitespaces) To UBound(whitespaces)
If c = whitespaces(j) Then
isWhitespace = True
Exit For
End If
Next
For j = LBound(additionals) To UBound(additionals)
If c = additionals(j) Then
isWhitespace = True
Exit For
End If
Next
If Not isWhitespace Then
endPos = i
Exit For
End If
Next
TrimWhitespace = Mid(txt, startPos, endPos - startPos + 1)
End Function
