エクセルVBAで DirectPrecedentsプロパティ

質問

DirectPrecedentsプロパティが同一シート内しかトレースできないことを利用して、他シートを参照しているセルを判定できないかと思い、下記のマクロを書いてみました。
残念ながら他シートを参照しているセルでエラーになってしまいます。
どのよに修正すればよいでしょうか？
なお、他シート参照の判定に"！"の存在を使わないのは、「名前定義」されたセルを参照している場合を想定しているためです。

Sub TEST01()
With ActiveSheet
On Error GoTo line
For Each c In .UsedRange.SpecialCells(xlCellTypeFormulas, 23)
On Error GoTo 0
c.Select
If c.DirectPrecedents.Address = "" Then'ここでエラー
MsgBox c.Address & "は他シート参照"
Else
MsgBox c.Address & "は" & c.DirectPrecedents.Address & "参照"
End If
Next
End With
line:
MsgBox "数式がありません。"
End Sub

回答No.2

Wendy02

こんにちは。

うーん、今の状態では、基本的に無理があるかなって思います。
私の作ったものでも、名前定義とか関係なく、数式が複合的になると、うまくいきません。数式を切り分けする必要があるようです。

'-------------------------------------------
Sub FindReferencesMacro()
'DirectPrecednts を使ったマクロ
　　Dim c As Variant
　　Dim buf As Variant
　　Dim pAddr As String

　　With ActiveSheet
　　　　On Error GoTo ErrHandler
　　　　For Each c In .UsedRange.SpecialCells(xlCellTypeFormulas, 23)
　　　　　　On Error Resume Next
　　　　　　buf = Empty
　　　　　　buf = c.DirectPrecedents.Address
　　　　　　On Error GoTo 0
　　　　　　If IsEmpty(buf) Then
　　　　　　　　FindPrecedent c.FormulaLocal, pAddr
　　　　　　Else
　　　　　　　　pAddr = c.DirectPrecedents.Address
　　　　　　End If
　　　　　　MsgBox c.Address & " は " & pAddr & " を参照"
　　　　　　pAddr = ""
　　　　Next
　　End With
　　Exit Sub
ErrHandler:
　　MsgBox Err.Number & ": " & Err.Description
End Sub
Function FindPrecedent(ByVal strForml As String, ByRef strAdd As String)
　　Dim Matches As Object
　　Dim Match As Object
　　Dim w As String, s As String, c As String
　　If Not strForml Like "=?*" Then Exit Function
　　If InStr(strForml, "!") > 0 Then
　　　　With CreateObject("VBScript.RegExp")
　　　　　　.Pattern = "=(\[.*\])?(.*)\!(.*)"
　　　　　　.Global = True
　　　　　　Set Matches = .Execute(strForml)
　　　　　　If Not Matches Is Nothing Then
　　　　　　　　On Error Resume Next
　　　　　　　　w = Matches(0).SubMatches(0)
　　　　　　　　s = Matches(0).SubMatches(1)
　　　　　　　　c = Matches(0).SubMatches(2)
　　　　　　　　On Error GoTo 0
　　　　　　End If
　　　　End With
　　Else
　　　　FindPrecedent Application.Names(Mid$(strForml, 2)), strAdd
　　End If
　　If strAdd = "" Then
　　　　strAdd = w & s & "!" & c
　　End If
End Function

'-------------------------------------------