Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1853 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【71475】リンク元セルの選択 おぢちゃん 12/3/9(金) 8:30 質問[未読]
【71476】Re:リンク元セルの選択 n 12/3/9(金) 12:54 発言[未読]
【71482】Re:リンク元セルの選択 n 12/3/9(金) 23:00 発言[未読]
【71478】Re:リンク元セルの選択 ちん 12/3/9(金) 15:23 発言[未読]
【71492】Re:リンク元セルの選択 ちん 12/3/11(日) 23:23 発言[未読]
【71479】Re:リンク元セルの選択 UO3 12/3/9(金) 16:57 回答[未読]
【71480】Re:リンク元セルの選択 kanabun 12/3/9(金) 21:00 発言[未読]
【71484】Re:リンク元セルの選択 おぢちゃん 12/3/10(土) 1:31 発言[未読]
【71481】Re:リンク元セルの選択 UO3 12/3/9(金) 22:46 発言[未読]
【71483】Re:リンク元セルの選択 おぢちゃん 12/3/10(土) 1:06 発言[未読]
【71485】Re:リンク元セルの選択 hint 12/3/10(土) 9:28 発言[未読]
【71494】Re:リンク元セルの選択 hint 12/3/12(月) 20:59 発言[未読]
【71475】リンク元セルの選択
質問  おぢちゃん  - 12/3/9(金) 8:30 -
引用なし
パスワード
   お世話になります。
sheet1の多数のｾﾙから同一ﾌﾞｯｸ内の他の複数ｼｰﾄに向けて"ﾘﾝｸ貼り付け"がされています。
sheet1のﾘﾝｸ貼り付け"元"となっているｾﾙに一括で色をつけたいのですが,そのﾘﾝｸ"元"ｾﾙの選択方法がわかりません。
特定のﾘﾝｸ先のﾘﾝｸ"元"ｾﾙだけを選択する,といった条件はなく無条件にﾘﾝｸがかかっている"元"ｾﾙを選択したいのです。
ﾋﾝﾄをいただけないでしょうか？
【71476】Re:リンク元セルの選択
発言  n  - 12/3/9(金) 12:54 -
引用なし
パスワード
   ・Excelのバージョンが2002以降である。
・数式に、文字列としての『 ! 』を使っていない。
・数式に、定義した「名前」を使っていない。
以上の条件を全て満たすなら、[置換]機能で置換後の書式をセットして
『 ! 』から『 ! 』に置換するのが早い。
..と思います。
必要であれば「マクロ記録」でマクロ化できます。

[置換]が使えない状況なら数式が入力されたセルをLoopして
各セルごとに判断していかなければなりません。
数式が入力されたセルは SpecialCells(xlCellTypeFormulas) で取得できます。
他シートを参照しているかどうかは
DirectPrecedentsプロパティ で判断可能かもしれません。（数式の内容によります）
【71478】Re:リンク元セルの選択
発言  ちん  - 12/3/9(金) 15:23 -
引用なし
パスワード
   ▼おぢちゃん さん：こんいちわ、ちんといいます。
あくまでも、同一ブック内のリンク貼り付けということで、
参考までにUPします。
最終行と最終列を判断するところは、そちらのシート用に変更して下さい。
見つけた場合、黄色の塗りつぶしです。

Sub test()

Dim sht As Worksheet
Dim a As String

For Each sht In ActiveWorkbook.Sheets
　If sht.Name <> "Sheet1" Then
　　
　　'*** データを探すために、Ａ列(1)で、最終行を判断しました。
　　'*** (I65536)のIは、I列で最終行を探すために使用しました。基準となる列を入れてください。
　　For i1 = 1 To Worksheets(sht.Name).Range("I65536").End(xlUp).Row

　　'*** (IV13)の13値は、１３行目の列で最終列を探すために使用しました。基準となる行を入れてください。
　　　For i2 = 1 To Worksheets(sht.Name).Range("IV13").End(xlToLeft).Column
　　　　If InStr(1, Sheets(sht.Name).Cells(i1, i2).Formula, "=Sheet1!", vbBinaryCompare) = 0 Then　 '*** =Sheet1!　文字を検索
　　　　　'*** リンクなし
　　　　Else
　　　　　'*** リンクあり
　　　　　a = Replace(Sheets(sht.Name).Cells(i1, i2).Formula, "=Sheet1!", "", 1)　'**　=Sheet1!　文字を置き換え
　　　　　If Sheet1.Range(a).Interior.ColorIndex <> 6 Then　'***　黄色塗りつぶし
　　　　　　Sheet1.Range(a).Interior.ColorIndex = 6
　　　　　End If
　　　　End If

　　　Next i2
　　Next i1
　End If
　
Next sht
　　
End Sub

勘違いしてたらごめんなさい。
参考までに・・・
【71479】Re:リンク元セルの選択
回答  UO3  - 12/3/9(金) 16:57 -
引用なし
パスワード
   ▼おぢちゃん さん：

要件を誤解してたらごめんなさい。

Sub Sample()
　　Dim r As Object
　　Dim c As Range
　　
　　With Sheets("Sheet1").UsedRange　 'リンク貼付がセットされているシート
　　　　For Each c In .Cells
　　　　　　If c.HasFormula Then
　　　　　　　　If IsObject(Evaluate(c.Formula)) Then
　　　　　　　　　　Set r = Evaluate(c.Formula)
　　　　　　　　　　If TypeName(r) = "Range" Then
　　　　　　　　　　　　If Not r.Parent Is c.Parent Then
　　　　　　　　　　　　　　r.Interior.ColorIndex = 6
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　
　　Set r = Nothing
　　
End Sub
【71480】Re:リンク元セルの選択
発言  kanabun  - 12/3/9(金) 21:00 -
引用なし
パスワード
   ▼おぢちゃん さん： こんにちは〜
よこから　確認だけ スミマセン。

>sheet1の多数のｾﾙから同一ﾌﾞｯｸ内の他の複数ｼｰﾄに向けて"ﾘﾝｸ貼り付け"がされています。
>sheet1のﾘﾝｸ貼り付け"元"となっているｾﾙに一括で色をつけたいのですが,

（確認）
簡単のため、3枚の[Sheet1] [Sheet2] [Sheet3] があるとすると、
[Sheet1]　
　　リンク元 シート

[Sheet2] このシートに Sheet1 への参照がある
　たとえば、 [B2:B100] = "=Sheet1!A2"
　　
[Sheet3] このシートにも　Sheet1 への参照がある
　たとえば、 [C2:C100] = "=Sheet1!B2"
　　
ということでよろしいですか？

もしそうだとすると、難しいですねぇ
たとえば、Sheet1 内のセルを順にLoopして、そのセルが どこか他の
セルから参照されているかを調べる DirectDependents プロパティが
あります。
Sub try1()
　　Dim c As Range, r As Range
　　
　　With Sheet1.UsedRange
　　　　.Interior.ColorIndex = xlNone
　　　　For Each c In .Cells　　'Sheet1 内をループ
　　　　　　On Error Resume Next
　　　　　　Set r = c.DirectDependents　'cセルを参照しているセル
　　　　　　On Error GoTo 0
　　　　　　If Not r Is Nothing Then
　　　　　　　　c.Interior.ColorIndex = 6
　　　　　　　　Set r = Nothing
　　　　　　End If
　　　　Next
　　End With
End Sub
これを実行すると、Sheet1自身のどこかから参照のあるセルには
色がつきますが、そうでなく、別シートから参照されているセルには
残念ながら色がつきません。
------------------------------------------------------
DirectDependents プロパティは作業中のシートでのみ有効で、
リモート参照をトレースできないことに注意してください。
------------------------------------------------------
手動で、Sheet1の [A2]セルをアクティブにして、
[ツール]-[ワークシート分析]-[参照先のトレース]で調べたときは
Sheet2から Sheet1のA2 セルへの参照があるので、ちゃんと
別シートのアイコンが出て、Sheet1の[A2]からそのアイコンへ
矢印が描かれていたんですけどね。

よくわからないけど、力技で、
Bookの（Sheet1 以外の）すべてのシートをLoop して、
各シートの「数式の入っている」すべてのセルをしらみつぶしに
調べていって、 そこに "=Sheet1!A2" とかあれば、
Sheet1!A2 セルを色塗する、という方向（別シート、参照先から
Sheet1のリンク元セルを特定する）でなら、時間はかかるけれど
出来そうな気がします。（かぶりますが）
Sub try2()
　　Dim ws As Worksheet
　　Dim c As Range, r As Range, rs
　　Dim Ad$, ThisSheetname$, ss$
　　Dim dic As Object
　　Dim j As Long
　　
　　'------- 対象シートをアクティブにして実行 ------
　　Set dic = CreateObject("Scripting.Dictionary")
　　ThisSheetname = "=" & ActiveSheet.Name & "!"
　　For Each ws In Worksheets
　　　　If ws.Name <> ThisSheetname Then
　　　　　　On Error Resume Next
　　　　　　For Each c In ws.UsedRange.SpecialCells(xlCellTypeFormulas)
　　　　　　　　ss = c.Formula
　　　　　　　　j = InStr(ss, ThisSheetname)
　　　　　　　　If j > 0 Then dic(Mid$(ss, j + 1)) = Empty
　　　　　　Next
　　　　End If
　　Next
　　If dic.Count Then
　　　　ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
　　　　For Each rs In dic.Keys()
　　　　　　Excel.Range(rs).Interior.ColorIndex = 33
　　　　Next
　　End If
　　
End Sub
【71481】Re:リンク元セルの選択
発言  UO3  - 12/3/9(金) 22:46 -
引用なし
パスワード
   ▼おぢちゃん さん：

アップした私のコードは、Sheet1から他のシートを参照しているものを捜すちう理解でしたが
kanabunさんがいわれるように、他のシートからSheet1を参照している、
その参照されているSheet1のセルに色をつけるということであれば、アップ済みの私のコードの
｢参照の方向を逆にして｣以下のように書いてみました。

Sub Sample2()
　　Dim sh As Worksheet
　　Dim sh1 As Worksheet
　　Dim c As Range
　　Dim r As Range
　　
　　Set sh1 = Sheets("Sheet1")
　　sh1.Cells.Interior.ColorIndex = xlNone
　　
　　For Each sh In Worksheets
　　　　If Not sh Is sh1 Then
　　　　　　With sh.UsedRange
　　　　　　　　For Each c In .Cells
　　　　　　　　　　If c.HasFormula Then
　　　　　　　　　　　　If IsObject(Evaluate(c.Formula)) Then
　　　　　　　　　　　　　　Set r = Evaluate(c.Formula)
　　　　　　　　　　　　　　If TypeName(r) = "Range" Then
　　　　　　　　　　　　　　　　If r.Parent Is sh1 Then
　　　　　　　　　　　　　　　　　　r.Interior.ColorIndex = 6
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End With
　　　　End If
　　Next
　　
　　Set r = Nothing
　　
End Sub
【71482】Re:リンク元セルの選択
発言  n  - 12/3/9(金) 23:00 -
引用なし
パスワード
   >sheet1の多数のｾﾙから同一ﾌﾞｯｸ内の他の複数ｼｰﾄに向けて"ﾘﾝｸ貼り付け"がされています。
『他の複数ｼｰﾄに向けて"ﾘﾝｸ貼り付け"』
..失礼orz
逆でしたか。勘違いしました。

Sub recover()
　　'シート名によっては、シングルクォートの付加必要
　　Const X = "Sheet1" '"'1'"
　　Const PTN = X & "!([^+\-*/^=<>&,)\s]+)"
　　Dim reg As Object
　　Dim mc　As Object
　　Dim m　 As Object
　　Dim ws　As Worksheet
　　Dim rg　As Range
　　Dim r　 As Range
　　Dim s　 As String

　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Pattern = PTN
　　reg.Global = True
　　reg.IgnoreCase = True
　　For Each ws In Worksheets
　　　　If InStr(1, X, ws.Name, vbTextCompare) = 0 Then
　　　　　　On Error Resume Next
　　　　　　Set rg = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
　　　　　　On Error GoTo 0
　　　　　　If Not rg Is Nothing Then
　　　　　　　　For Each r In rg
　　　　　　　　　　s = r.Formula
　　　　　　　　　　If InStr(1, s, X, vbTextCompare) > 0 Then
　　　　　　　　　　　　Set mc = reg.Execute(s)
　　　　　　　　　　　　For Each m In mc
　　　　　　　　　　　　　　Debug.Print m.Value
　　　　　　　　　　　　　　'Excel.Range(m.Value).Interior.Color = vbYellow
　　　　　　　　　　　　Next
　　　　　　　　　　　　Set mc = Nothing
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　Set r = Nothing
　　　　　　End If
　　　　End If
　　Next
　　Set reg = Nothing
End Sub

『リンク貼り付け』だから単純な参照数式なのでここまで必要ないでしょうけど、一応。
【71483】Re:リンク元セルの選択
発言  おぢちゃん  - 12/3/10(土) 1:06 -
引用なし
パスワード
   皆様、多数のレスをありがとうございます。
ジャンプ機能を利用してできるのではないかな、と甘く見ておりました。
皆様のコードを見ると見慣れぬ文字列ばかりで・・・。

ただ今、検証できる環境にありませんので来週に再度返答させていただきます。
ただ動作の確認は出来ても、コード内容が理解できない事には…。
…頑張ります。
【71484】Re:リンク元セルの選択
発言  おぢちゃん  - 12/3/10(土) 1:31 -
引用なし
パスワード
   ▼kanabun さん：

>（確認）
>簡単のため、3枚の[Sheet1] [Sheet2] [Sheet3] があるとすると、
>[Sheet1]　
>　　リンク元 シート
>
>[Sheet2] このシートに Sheet1 への参照がある
>　たとえば、 [B2:B100] = "=Sheet1!A2"
>　　
>[Sheet3] このシートにも　Sheet1 への参照がある
>　たとえば、 [C2:C100] = "=Sheet1!B2"
>　　
>ということでよろしいですか？

そうです。
[sheet1]の各セル内の計算結果や数値を、他の複数のシートと複数のセルに"リンク貼り付け"で「飛ばし」ています。
しかし、本来他のシートに「飛んで」いなければいけないセルの値が「放置」されている場合があるので、検算の手始めとして「放置セル」を洗い出そうとしてます。
【71485】Re:リンク元セルの選択
発言  hint  - 12/3/10(土) 9:28 -
引用なし
パスワード
   もう十分な回答がありますけど、NavigateArrowを使うこんな方法は
どうでしょうか。nさんの正規表現手法が常識的で推奨ですけれど。

Sub test()
　　Dim ws　　　　　As Worksheet
　　Dim myRange　　 As Range
　　Dim r　　　　　 As Range
　　Dim refercell　 As Range
　　Dim k　　　　　 As Long

　　Application.ScreenUpdating = False
　　Set ws = ActiveSheet
　　ws.Cells.Interior.ColorIndex = xlNone
　　ws.ClearArrows
　　Set myRange = Union(ws.Cells.SpecialCells(xlCellTypeFormulas, 23), _
　　　　　　　　　　　　ws.Cells.SpecialCells(xlCellTypeConstants, 23))
　　　　　　　　　' ↑ 少し甘い。該当なしの場合エラーになるよ。
　　For Each r In myRange
　　　　r.ShowDependents
　　　　On Error Resume Next
　　　　k = 0
　　　　Do
　　　　　　k = k + 1
　　　　　　Set refercell = r.NavigateArrow(TowardPrecedent:=False, _
　　　　　　　　　　　　　ArrowNumber:=1, LinkNumber:=k)
　　　　　　If Err.Number = 0 And refercell.Parent.Name <> "Sheet1" Then
　　　　　　　　r.Interior.Color = vbYellow
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop Until Err.Number <> 0 _
　　　　　　　　Or refercell.Address(external:=True) _
　　　　　　　　　　= r.Address(external:=True)
　　　　On Error GoTo 0
　　Next
　　ws.Activate
　　ws.ClearArrows
　　Application.ScreenUpdating = True
End Sub

これであれば、
・単純参照（例： =Sheet1!A1のような）ではない、
　 = B1 + Sheet1!A1 のような参照でもOKです。
・また、名前を介した参照でもOKかと思います。
（この例では、そうしたものは無い前提かもしれませんが）　
【71492】Re:リンク元セルの選択
発言  ちん  - 12/3/11(日) 23:23 -
引用なし
パスワード
   独り言。
私が、For文・Do文・RangeやCELL　を多様するのは、
処理のイメージや仕様を理解しやすいようにと思い・・・

質問者のレベルが初級・中級・上級　か解らないですしね。
使ってるパソコンのOS、Excelのバージョンも解らない。

参考に載せてるコードは、どのExcelのバージョンでも動作できるように
UPしてます。

早く、私以外の発言者さんのレベルに近づくように願っております。
【71494】Re:リンク元セルの選択
発言  hint  - 12/3/12(月) 20:59 -
引用なし
パスワード
   問題を読み違えていたみたいです。
リンク貼り付けって、=Sheet1!A1みたいなことを言うのでしたか。
私は、外部参照している計算式のような一般的なものを考えていたのです。
でしたら、正規表現必須ではないですね。
関係者の皆さん、どうも失礼しました。
　
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1853 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free