[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『数式のリンク先シート名を拾い出したい』（げん）
こんにちは。よろしくお願いします。
教えていただきたいのは、セルに入力された式からリンク先のシート名だけを拾い出す方法です。
やりたいことは[[20110916141710]]『シート名の一括変更と並び替え』と近いのですが
シート名を拾い出したい対象がハイパーリンクではなく同一ブック別シートへのリンクです。
また、シート名は原則0〜99の数字のみですが、ときおりSheet1や個人名などになっているもの、
数値が直打ちされてリンクになっていないものもあります。
※リンクされていない値があった場合はエラーを出して処理を中止するつもりです。
校内検索して調べましたが
[[20170514141418]]『あるセルに入力されている時、そのリンク先のシートを一括印刷』
ここにあるマナさんの方法は数字だけのシート名では正しい結果が得られずうまくいきませんでした。
正規表現という方法も調べて、できないながらにやってみました。
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "'([0-9]|[1-9][0-9])'!"
RE.Test(Cells(1,1).Formulalocal)
これで数字だけのシートを拾い出そうとしましたが、ここから先がわかりませんでした。
（シート名が数字だけでないシートも拾い出したいのですが、今のところ未着手です）
作りかけですがいまのところこんなコードになっています。
Private Function GetLinkList(ByVal topRange As Range) As String()
Dim RE As Object
Dim tmp() As String
Dim i As Long
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "'([0-9]|[1-9][0-9])'!"
With topRange
ReDim tmp(.Parent.Cells(Rows.Count, .Column).End(xlUp).Row - .Row)
End With
For i = LBound(tmp) To UBound(tmp)
If RE.Test(topRange.Offset(i).FormulaLocal) Then
tmp(i) = ""
End If
Next
GetLinkList = tmp
End Function
どんなことでもアドバイスをいただけるとうれしいです。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
正規表現検索は（自分ができないので）いったん放棄して
リンク先のシートは同一ブック内に必ずある（無ければエラーとする）ので
ブック内のシート一覧をDictionaryに入れて調べるやり方をとりました。
Private Function GetLinkList(ByVal topRange As Range) As Worksheet()
Dim myDic As Object
Dim myList As Variant
Dim myFml As Variant
Dim mySh() As Worksheet
Dim myRng As Range
Dim ws As Worksheet
Dim i As Long
Dim j As Long
Set myDic = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
myDic.Add ws.Name, ws
Next ws
myList = myDic.keys
With topRange
Set myRng = .Parent.Range(.Cells(1), .Parent.Cells(Rows.Count, .Column).End(xlUp))
End With
myFml = Application.Transpose(myRng.FormulaLocal)
ReDim mySh(LBound(myFml) To UBound(myFml))
For i = LBound(myFml) To UBound(myFml)
For j = LBound(myList) To UBound(myList)
If InStr(myFml(i), myList(j) & "!") > 0 Or _
InStr(myFml(i), "'" & myList(j) & "'!") > 0 Then
Set mySh(i) = myDic(myList(j))
Exit For
End If
Next j
Next i
GetLinkList = mySh
End Function
ひとまずシートオブジェクトを配列にしていますが、仮の仮のような状態です。
（げん） 2021/04/01(木) 12:31
InStr(myFml(i), myList(j) & "!") > 0 Or InStr(myFml(i), "'" & myList(j) & "'!") > 0
この条件式では「A10」シートを「10」シートと誤認するエラーがあり使えませんでした。
セルの数式に含まれる同一ブックの他シート名を上手に拾い出せる式はないでしょうか？
（げん） 2021/04/02(金) 09:50
（γ） 2021/04/02(金) 15:32
参照元のトレースは思いつきませんでした。ご助言ありがとうございます。
（げん） 2021/04/02(金) 15:43
最初に正規表現を使ったものを示します。 ・対象となるシートをアクティブにした状態で、 ・以下の、main1マクロを実行して下さい。 ・イミディエイトウインドウに結果を出力しています。
Option Explicit
'アクティブシートの数式のうち、他のシートを参照しているものを抽出し、 'イミディエイトウインドウに出力 ' Sheet1!A1 <== (Sheet2,Sheet3) という形式 Dim re As Object
Sub main1()
Dim dic As Object
Dim ws As Worksheet
Dim s As String
Dim r As Range
Dim mySheets As Variant '参照している他シート（配列）
Dim precedentSheets As String '参照している他シート（文字列）
Dim j As Long
Dim p As Long
Dim cnt As Long
'正規表現の設定
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("Scripting.Dictionary")
For Each ws In ThisWorkbook.Worksheets
If InStr(ws.Name, "'") > 0 Then
dic(Replace(ws.Name, "'", "''")) = Empty
Else
dic(ws.Name) = Empty
End If
Next
s = Join(dic.keys, "|")
With re
.Global = True
.Pattern = "\b(" & s & ")!|'(" & s & ")'!"
'.Pattern = "(\B[^\b]*?)!|'([^']*?)'!"
End With
For Each r In ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
'セルrの参照元が他シートであるものを一次元配列で受け取る
mySheets = getPrecedentSheets2(r.Formula)
'結果をイミディエイトウインドウに出力（出力はお好きなようにして下さい）
cnt = 0
On Error Resume Next
cnt = UBound(mySheets)
On Error GoTo 0
If cnt > 0 Then
If cnt = 1 Then
precedentSheets = mySheets(1)
Else
precedentSheets = "(" & Join(mySheets, ",") & ")"
End If
Debug.Print deleteBookName(r.Address(False, False, external:=True)) _
& " <== " & precedentSheets
End If
Next
End Sub
Function getPrecedentSheets2(s As String) As Variant
Dim mat() As String
Dim mCount As Long
Dim matches As Object
Dim k As Long
Set matches = re.Execute(s) '検索の実行
mCount = matches.Count
If mCount > 0 Then
ReDim mat(1 To mCount)
For k = 1 To mCount
mat(k) = matches(k - 1).SubMatches(0) & matches(k - 1).SubMatches(1)
Next
End If
getPrecedentSheets2 = mat
End Function
Function deleteBookName(s As String) As String
Dim ss As String
ss = Replace(s, "'", "")
deleteBookName = Mid(ss, InStr(ss, "]") + 1)
End Function
# 一部に誤りがありましたので、修正しました。（4/5 9:12)
（γ） 2021/04/02(金) 22:50
次は、「参照元のトレース」を利用する方法です。
・これは、「参照元のトレース」を実行すると、 他シートを参照している場合、破線の矢印が表示されますね。
その矢印をダブルクリックすると、 「ジャンプ」のための「移動先」が表示されますね。
こいつを利用してやろうという魂胆です。 ただ、かなり趣味的なコードなので、余り見たことはないように思います。
・これの利点は、計算式のなかに、他シートを指す「名前定義」があるとき、 正規表現で、Formulaプロパティを見てもわかりませんが、 この手法だと把握することができます。
・念入りな検証していないので、バグがあるかもしれません。
【使い方】 ・標準モジュールにコピー ・対象シートをアクティブにして ・マクロmain2を実行 ・結果はtoolsheetのB列に表示されます。
【参考コード】 Option Explicit
'他シート参照しているセルについて ' "Sheet1!A1 <== Sheet2!A2" のような形式で参照情報を作成する。 '結果は、予め作成した"toolsheet"に書き込む（■シート名は修正したいただいて構いません）
Dim mat() As String '結果保存用配列 Dim p As Long 'そのindex
Sub main2()
Dim ws As Worksheet
Dim wsOut As Worksheet
Dim myRange As Range
Dim r As Range
Dim j As Long
ReDim mat(0 To 0)
Application.ScreenUpdating = False 'これは必須です。（スピードが断然違う）
p = 0
Set ws = ActiveSheet
Set wsOut = Worksheets("toolsheet") '■修正可
'式の入ったセルを特定
On Error Resume Next
Set myRange = ws.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
On Error GoTo 0
If Not myRange Is Nothing Then
For Each r In myRange
'セルrが参照しているセルが他シートであるものを
'配列matに書き込む(NavigateArrowを利用)
Call getPrecedents(r)
Next
End If
Set myRange = Nothing
'結果の書込
wsOut.Columns("B").ClearContents
wsOut.[B1].Resize(UBound(mat) + 1, 1).Value _
= Application.Transpose(mat)
End Sub
Function getPrecedents(r As Range)
Dim referCell As Range
Dim k As Long
Dim j As Long
Dim s As String
r.Parent.ClearArrows
r.ShowPrecedents '参照元
k = 0
On Error Resume Next
Do
k = k + 1
'指定されたセル範囲のトレース矢印をたどって、
'参照元(k番目)を返す。
Set referCell = r.NavigateArrow(TowardPrecedent:=True, _
ArrowNumber:=1, LinkNumber:=k)
If Err.Number = 0 Then
If referCell.Parent.Name <> r.Parent.Name Then '他シートの参照なら
ReDim Preserve mat(p)
mat(p) = myAddress(r) & " <== " & myAddress(referCell)
p = p + 1
Else
Exit Do
End If
Else
Exit Do
End If
Loop
On Error GoTo 0
r.Parent.ClearArrows
End Function
Function myAddress(r As Range) As String
Dim s As String
s = r.Address(RowAbsolute:=False, ColumnAbsolute:=False, external:=True)
s = Replace(s, "'", "")
myAddress = Mid(s, InStr(s, "]") + 1)
End Function
（γ） 2021/04/02(金) 22:52
（γ） 2021/04/02(金) 23:28
昔シートの分析用に数式の一覧を作成した時のものを関数に直してみました 一見良さげに見えるので試してみて下さい ユーザー定義関数としても使えます
Function ブック内他シート(Target As Range) As String
Dim W1 As String
Dim W9 As String
Dim regEx As RegExp 'As Object
Dim Matches As MatchCollection 'As Object
Dim i As Long
Dim WF As String
Set regEx = New RegExp
regEx.Pattern = "!.*?[-+*/=:,&()<> \]]"
regEx.Global = True
WF = Target.Formula
Set Matches = regEx.Execute(StrReverse(WF))
For i = 0 To Matches.Count - 1
W1 = Mid(Matches.Item(i), 2, Len(Matches.Item(i)) - 2)
W1 = Replace(W1, "'", "")
W1 = Replace(W1, Target.Parent.Name, "")
If W1 <> "" Then W9 = W9 & IIf(W9 = "", "", ",") & W1
Next
Set regEx = Nothing
Set Matches = Nothing
ブック内他シート = StrReverse(W9)
End Function
（チオチモリン） 2021/04/03(土) 09:49
インデントを修正しました。
Function ブック内他シート(Target As Range) As String
Dim W1 As String
Dim W9 As String
Dim regEx As RegExp 'As Object
Dim Matches As MatchCollection 'As Object
Dim i As Long
Dim WF As String
Set regEx = New RegExp
regEx.Pattern = "!.*?[-+*/=:,&()<> \]]"
regEx.Global = True
WF = Target.Formula
Set Matches = regEx.Execute(StrReverse(WF))
For i = 0 To Matches.Count - 1
W1 = Mid(Matches.Item(i), 2, Len(Matches.Item(i)) - 2)
W1 = Replace(W1, "'", "")
W1 = Replace(W1, Target.Parent.Name, "")
If W1 <> "" Then W9 = W9 & IIf(W9 = "", "", ",") & W1
Next
Set regEx = Nothing
Set Matches = Nothing
ブック内他シート = StrReverse(W9)
End Function
（チオチモリン） 2021/04/03(土) 09:51
ところで、エッジケースですが、シート名にスペースが入っている時、
例えば、
='aa bb cc'!A1
などという場合は、ccというシート名を返しますので、修正が必要かと思います。
spaceが悪さをしてちょっと対応策がすぐには思いつきません。
なにかアイデアがあれば教えて下さい。
（γ） 2021/04/03(土) 13:25
（γ） 2021/04/03(土) 13:39
>シート名が数字だけでないシートも拾い出したい とありましたね。
>"'"を含む場合とそうでない場合の両方を"|"で繋げたパターンにすればできそうですね 正規表現は苦手な部類になりますので とりあえず ↓ で
Function ブック内他シート(Target As Range) As String
Dim W1 As String
Dim W9 As String
Dim regEx As RegExp
Dim Matches As MatchCollection
Dim i As Long, St As Long, L As Long
Dim WF As String
Set regEx = New RegExp
regEx.Pattern = "!.*?[-+*/=:,&()<> \]]"
regEx.Global = True
WF = StrReverse(Target.Formula)
Set Matches = regEx.Execute(WF)
For i = 0 To Matches.Count - 1
With Matches
St = .Item(i).FirstIndex + 2
L = IIf(InStr(.Item(i), "'") = 0, Len(.Item(i)) - 2, InStr(St + 1, WF, "'") - St + 1)
End With
W1 = Mid(WF, St, L)
W1 = Replace(W1, "'", "")
W1 = Replace(W1, Target.Parent.Name, "")
If W1 <> "" Then W9 = W9 & IIf(W9 = "", "", ",") & W1
Next
Set regEx = Nothing
Set Matches = Nothing
ブック内他シート = StrReverse(W9)
End Function
（チオチモリン） 2021/04/04(日) 09:28
γさん、チオチモリンさん、アドバイスとコードをありがとうございます！
内容を学んで、また報告したいと思います。
（げん） 2021/04/05(月) 08:11
1. やっぱり単語境界が有効なことがわかりました。過去発言のコード(main1)を修正しています。
s は Sheet1|Sheet2 といったシート名を "|" で連結したものとして、
.Pattern = "\b(" & s & ")!|'(" & s & ")'!"
とすればよかったようです。
（文字セット[]のなかに\bを入れるという初歩的間違いでした。）
2．なお、シート名の中に"'" があると、数式中では "''"と二つ重ねてエスケープされるんですね。 まあ、レアケースですが。これも手当してみました。
# 上記検討中に気づきましたが、チオチモリンさんの正規表現に、 # ^(累乗演算子)も入れるとよいかもしれません。 （γ） 2021/04/05(月) 09:21
書いていただいたコードをいろいろなケースにあてはめて実験してみました。
シート名に「!」「'」や半角スペースが含まれるときに不具合が起きてしまいましたが
NavigateArrowを使ったコードでは過不足なくシートを拾い出すことができました。
しかし、回答の中に「かなり趣味的なコード」とありますが、
これはあまり実用向けではないコードでしょうか。
（げん） 2021/04/06(火) 09:51
追記しておきます。
一般的な話として、 ・Precedents プロパティや、 Dependents プロパティ DirectPrecedents プロパティ、DirectDependentsプロパティ などはいずれもシート内の参照だけが対象です。
・従って、リモート参照（シート外の参照。他ブックも含む）を調べる際に、 NavigateArrowは有効なので、 これを機に閲覧者にも、ひとつのTipsとして記憶の片隅に留めて頂きたい。
■以下、使い方の要点をメモしておきます。
・例えば、 Sheet1!A1 に "=D1+Sheet2!A1+Sheet3!A1" という式があるとします。
・つまり、
シート外の参照と、シート内の参照が混在している場合であるが、
・ArrowNumber=1としてNavigateArrowを実行することで、シート外の参照にジャンプできます。
・ArrowNumber=2としてNavigateArrowを実行することで、シート内の参照にジャンプできます。
（下部にある参考コードで確認されたい）
・シート内の参照が複数あれば、ArrowNumberは2以降に続きます。
・従って、シート外の参照にだけ興味があれば、 ArrowNumber=1としてNavigateArrowを実行するだけでよい。 (ちなみに、そのシート外は、同一ブック内も、他ブックもまとめてひとつの矢印です）
・そのリモート参照が複数(n個)ある場合は、 LinkNumber引数に 1から n までをセットすればよい。
・従って、LinkNumber引数を1から順次増やしていって、エラーが発生するまで繰り返します。
コードでは、以上のことを前提に、シート外の参照を見つけているわけである。 （上記のふるまいが了解されていれば、それ以外は特に難しいことは何もない）
なお、参照しているセルにその都度ジャンプする仕様なので、 画面更新を抑止したうえでマクロを実行しないと、 著しい速度低下を招くことに注意して下さい。（むろんコードには反映済みです）
■【動作確認のための検証用コード】以下をステップ実行すると、動作が理解できるでしょう。
Sub check() 'Sheet,Sheet2,Sheet3があるものとします。
Dim refCell As Range
Dim r As Range
'テストデータ
Set r = Sheet1.Range("A1")
r.Formula = "=D1+Sheet2!A1+Sheet3!A1"
'「参照元のトレース」
r.ShowPrecedents
'-----------------------------
' シート外の参照と、シート内の参照が混在している場合、
' シート外の参照が ArrowNumber=1 ,
' シート内の参照が ArrowNumber=2 と設定することで利用できる。
'-----------------------------
Set refCell = r.NavigateArrow(TowardPrecedent:=True, _
ArrowNumber:=1, LinkNumber:=1)
Debug.Print refCell.Address(external:=True) 'シート外(Sheet2!A1)の参照
'-----------------------------
Set refCell = r.NavigateArrow(TowardPrecedent:=True, _
ArrowNumber:=2, LinkNumber:=1)
Debug.Print refCell.Address(external:=True) 'シート内(Sheet1!D1)の参照
'-----------------------------
Set refCell = r.NavigateArrow(TowardPrecedent:=True, _
ArrowNumber:=1, LinkNumber:=2)
Debug.Print refCell.Address(external:=True) 'シート外の参照が複数あれば、
'LinkNumberを順次設定すればいい
End Sub
（余談） # なお、以前にも書いたことがあるが、「参照元」と「参照先」という用語について。 # A1 に "=A2" という計算式があるとき、 # A2 は A1 の「参照元(precedents)」であり、 # A1 は A2 の「参照先(dependents)」である、と日本語で呼ぶことになっているが、 # 日本語の語感からすると、A1がA2を参照しているわけだから、 # 参照「元」がA1 で、 # 参照「先」がA2 であるというのが、自然だと思う。 # precedentsというのは、そのセルの計算に先だって計算が必要なものという意味だろうし、 # dependentsというのは、そのセルに依存しているセルという意味でしょう。 # もっと適切な翻訳があっただろと思う。 # # https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12148120502 # では常連回答者が、"これはMicrosoft社の誤訳である"と言いきっています。 # # http://itpro.nikkeibp.co.jp/pc/article/column/20081118/1009755/?itp_leaf_ind # 「田中 亨」（テクニカルライター） # Excel用語は意味が逆？――計算対象のセルは「参照元」か「参照先」か（第71回） # などという記事もあるようです。 # （2ページ目以降に詳細が記載されているようだが、会員のみ閲覧可能らしい。） # # 確かに、何か最初にボタンを掛け違えた気配が濃厚で、いつも、混乱する自分がいる。
（γ） 2021/04/07(水) 09:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.