エクセルでこんなことできますか？

いつもお世話になります。エクセルのバージョンは2010以降でお願いしたいのですが。
セル（結合してあります）の背景色を変えるのですが、条件があります。
あるセル（例えば、A１）に、結合してあるセル（例えばG1:I5)へリンクが設定あります。
このようなリンクが張ってあるものがいくつかあります。
ここでA1をクリックすると、当然G1:I5の範囲を□で囲い表示するわけですが、
この□で囲まれているG1:I5の背景色を変更したい。（例えば水色に）
そして、違うセルへカーソルを移動させると、G1:I5の背景色を白（元の色）に戻したい。

以上です。よろしくお願いします。

No.7 ベストアンサー 回答者： ママチャリ 回答日時： 2019/03/09 09:55

こんなのは、どうでしょう。

FollowHyperlinkイベントプロシジャで、飛び先のセルにMYRNGという名前を付けた後に、条件付き書式で色を付けます（条件付きと言いながら、必ずTrueなのですが・・・）。
違うセルが選択された時に、SelectionChangeイベントプロシジャで、先ほど名前を付けたMYRNGの条件付き書式を削除しています。

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
ActiveWorkbook.Names.Add Name:="MYRNG", RefersTo:="=" & ActiveSheet.Name & "!" & Selection.Address
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=TRUE"
Selection.FormatConditions(1).Interior.Color = 65535
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Range("MYRNG").FormatConditions.Delete
End Sub

No.8 回答者： WindFaller 回答日時： 2019/03/10 11:43

No.6 の回答はしましたが、どうも今の時点では、No.7 様のコードのほうが良いようです。

私は、オプションで、ハイパーリンクを複数の色付けを考えていましたが、成功しませんでした。
簡単なコードで済むなら、簡単なほうがよいです。
ただ、私なら、
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
のCallBack のTarget 変数は、利用します。

この回答へのお礼

みなさま、ご回答ありがとうございます。
家族共々インフルエンザ（？）もどきで伏せっていて、回答を確認すらできていませんでした。
ママチャリさま、WindFallerさま、ご指摘のコードを勉強しながら試してみます。
ありがとうございます。

お礼日時：2019/03/13 07:59

No.6 回答者： WindFaller 回答日時： 2019/03/08 23:36

違う手法を考えてみました。

これは、複数の場所に色をつけることはできません。
ハイパーリンクをひとつクリックすれば、そのリンク場所の色が塗られます。

'//上書きで貼り付けてください。
Dim colAdr As New Collection
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim h As String
h = Target.SubAddress
Range(h).MergeArea.Interior.ColorIndex = 8 '水色
On Error Resume Next
colAdr.Add h, h
On Error GoTo 0
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　Dim Adr As String
　Dim cl As Variant
　Dim cnt As Long
　On Error Resume Next
　If Target.Hyperlinks.Count > 0 Then Exit Sub
　Me.CheckColors
　cnt = colAdr.Count
　If cnt > 1 Then
　　For Each cl In colAdr
　　　If Not Intersect(Range(cl).MergeArea.EntireRow, Target) Is Nothing Then
　　　　Adr = cl
　　　　Exit For
　　　End If
　　Next cl
　ElseIf cnt = 1 Then
　　Adr = colAdr.Item(1)
　End If
　If Intersect(Range(Adr), Target) Is Nothing And cnt <> 0 Then
　　Range(Adr).MergeArea.Interior.ColorIndex = xlColorIndexNone
　　colAdr.Remove Adr
　End If
　On Error GoTo 0
End Sub
Sub CheckColors()
　Dim h As String
　Dim hi As Object
　Dim i As Long
　Set cc = colAdr
　For Each hi In Me.Hyperlinks
　　h = hi.SubAddress
　　If Range(h).MergeArea.Interior.ColorIndex <> xlColorIndexNone Then
　　　i = i + 1
　　　colAdr.Add h, h
　　End If
　Next
End Sub

No.5 回答者： WindFaller 回答日時： 2019/03/08 20:12

複数のリンクに作動するように変えてみましたが、何かがすっきりしていません。

イメージとしては、たぶん、スイッチがハイパーリンクで、オン・オフを色で表すという感じではないかと思います。
もうちょっと待ってください。

だから、これはイメージとは違い正確性に欠けます。臨時の措置です。

'//シートモジュール
Dim strAdr As String
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
On Error Resume Next
If Not Intersect(Range(Target.SubAddress), ActiveCell) Is Nothing Then
　Range(Target.SubAddress).MergeArea.Interior.ColorIndex = 8
　strAdr = Target.SubAddress
End If
　 Application.Goto Range(Target.SubAddress)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　On Error Resume Next
　If Intersect(Range(strAdr), Target) Is Nothing Then
　　Range(strAdr).Interior.ColorIndex = xlColorIndexNone
　End If
　If Err() <> 0 Then
　　If Target.MergeCells And IsNull(Target.Interior.ColorIndex) Then
　　　Target.Interior.ColorIndex = xlColorIndexNone
　　End If
　End If
　On Error GoTo 0
End Sub

No.4 回答者： WindFaller 回答日時： 2019/03/06 22:26

No.3の回答者です。

>もっと10～15個ある場合はどうすればいいのでしょうか？
>不勉強が身にしみます。

そんなことはないのですが、この質問をみて確信したことがひとつあります。時代が変わっているということですね。
質問そのものが、今までにない内容なのです。だんだん、私はついていけなくなっているようです。
もう、ちょっと待ってください。しかし、まったく違う考えで回答する人物が現れてくるかもしれません。

No.3 回答者： WindFaller 回答日時： 2019/03/05 18:17

多少問題はあるとは思いますが、とりあえずアップしておきます。

説明は、No.2様の通りのつもりだったけれども、変えてみました。やっぱりコードは書くまで分からないです。色塗りしたまま保存した場合は、strAdr に残したものは消えてしまいます。それをどこかのセルに書くか、以下のように、エラーが発生した場合を想定して消す（結合セルの中でクリック)。

残る問題は複数存在する場合。(まだ考えていません)
ふたつでセットです。

'//シートモジュール
Dim strAdr As String
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Not Intersect(Range(Target.Name), ActiveCell) Is Nothing Then
　Range(Target.Name).Interior.ColorIndex = 8
　strAdr = Target.Name
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　On Error Resume Next
　If Intersect(Range(strAdr), Target) Is Nothing Then
　　Range(strAdr).Interior.ColorIndex = xlColorIndexNone
　End If
　If Err() <> 0 Then
　　If Target.MergeCells And IsNull(Target.Interior.ColorIndex) Then
　　　Target.Interior.ColorIndex = xlColorIndexNone
　　End If
　End If
　On Error GoTo 0
End Sub

この回答へのお礼

なるほど、そういうことですか。
できることがわかりうれしい限りです。
ただ、ご提示いただいたコードは
２箇所のみですね？
もっと10～15個ある場合はどうすればいいのでしょうか？

不勉強が身にしみます。

お礼日時：2019/03/05 19:31

No.2 回答者： fujillin 回答日時： 2019/03/05 17:11

こんにちは

「リンクをたどった時だけセルの色を変える」野に対して、直接の操作で「被リンクセルを選択した場合は何もしない」という考え方で良いのですよね。
イマイチはっきりと内容を把握できていないので、考え方のみとなりますが、以下のような仕組みを作成することで、ご質問の内容を実現できないでしょうか。（ひとまず、同一シート内で考えました）

シートモジュールのVBAで、アドレス及び色の記録用変数をシートレベルで用意しておきます。

Worksheet_FollowHyperlinkイベントで
・選択範囲をアドレスに記録、現在の色を控えておく
・選択範囲を水色にする

Worksheet_SelectionChangeイベントで
・アドレスの記録があれば、その範囲の色を控えの色に戻す
・アドレスの記録をクリア

この回答へのお礼

なるほど、そういうことですね。
勉強します。

ありがとうございました。

お礼日時：2019/03/05 19:27

No.1 回答者： よろずやkinchan 回答日時： 2019/03/05 16:40

A1をダブルクリックすると、G1:I5の範囲を□で囲い表示されますね。

（Excel365での標準の動作）

シングルクリックで動作させたいなら、こんな感じかな。

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim Precedents As Range
Application.EnableEvents = False
On Error Resume Next
Set Precedents = Target.DirectPrecedents
If Not Precedents Is Nothing Then
Union(Target, Precedents).Select
End If
Application.EnableEvents = True
End Sub

この回答へのお礼

回答、ありがとうございます。
正常に作動しているのかがよくわからないので、
勉強します。

ありがとうございました。

お礼日時：2019/03/05 19:26