[[20130523120754]]　『セルの色付』（初心者）　ページの最後に飛ぶ

 『セルの色付』（初心者）

     A          B            C

 1      3		     1
 2  みかん		みかん
 3  りんご		りんご
 4       2		     4
 5       5              みかん
 6  ぶどう              ぶどう
 7  いちご              いちご
 8       5		     5

　A20からA29までのセルにカーソルを持っていくと該当のセルに赤色表示する方法
　例えばA29「ぶどう」にカーソルを持っていくとA6、C6の「ぶどう」のセルに赤色を付ける数式をお教えください。宜しくお願いします。

 『数式で』・・・・う～ん・・・・

 A20～A29 を選択するということなら、やりくりして、それらしいことができると思うけど
 『マウスを、その上に持っていくだけ』ということなら『数式』ではちょっと・・できないんじゃない？

 (ぶらっと)

 とりあえず A20:A29 のいずれかのセルを『選択する』というベースで。

 ・A1:C8 を選択
 ・条件付き書式　「数式が」　=AND(CELL("col")=1,CELL("row")>=20,CELL("row")<=29,OFFSET($A$20,CELL("row")-20,)=A1)
 　　　　　　　　　背景色を赤に。
 　（数式自体は、もっとスマートなものもあると思うけど）

 ・ちょっとだけおまじない。
 　シートタブを右クリックして、でてくるところ（シートモジュール）に以下を貼り付け。

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Me.Calculate
 End Sub

 (ぶらっと)

 条件付き書式で数式をいれてA20のセルにマウスを持って行きシートをとじて開くとできますが、
 ほかのA22のセルにマウスを行くだけでは変わりません、
 無理なのでしょうか、初心者なので宜しくお願いします（初心者）

 >条件付き書式で数式をいれてA20のセルにマウスを持って行きシートをとじて開くとできますが、
 >ほかのA22のセルにマウスを行くだけでは変わりません

　ん？　セルをマウスで選択（クリック）する必要があるけど、選択すればA20であろうがA22であろうが

 その値を持つ A1:C8のセルが赤くなると思うけど？

 >シートをとじて開くとできますが

 この意味がよくわからないけど・・・
 条件付き書式設定は A1:C8 を選択した状態で設定してくれているよね？
 また、シートモジュールにもおまじないを貼り付けてくれているよね？

 不思議だねぇ・・・

 ところで、『お遊び』でセルを選択せず、マウスポインターを当てれば赤色になるコードを。

 シートにフォームツールボタンを配置して、キャプションを　"監視停止中" といったものに。
 で、以下の、コードを標準モジュールに貼り付けたうえで、そのボタンに、Test をマクロ登録。
 ボタンをクリックすると、マウスの監視ロジックが裏で回って、マウスポインターがA20:A29のどこかにきたら
 A1:C8の中の同じ値のセルが赤くなる。コードでは条件付き書式を使っているので、マウスポインターが
 はずれれば、もし、そのセルに別途背景色が塗られていれば、その色に戻る。
 実行中は、シート上の重い操作や別マクロの実行は、効率が少し落ちるかも。
 そういったときは、もう一度ボタンをクリックすると監視は停止。再度クリックすると、再び、監視実行。

 Option Explicit

 Private Declare Function GetCursorPos Lib "User32" (lpPoint As MousePoint) As Long

 Type MousePoint
    x As Long
    y As Long
 End Type

 Dim DoLoop As Boolean
 Dim mySh As Worksheet

 Sub Test()
    Set mySh = ActiveSheet
    If DoLoop Then
        ActiveSheet.Shapes(Application.Caller).DrawingObject.Caption = "監視停止中"
        監視終了
    Else
        ActiveSheet.Shapes(Application.Caller).DrawingObject.Caption = "監視実行中"
        監視開始
    End If
 End Sub

 Private Sub 監視開始()
    Dim r As Object
    Dim oldr As Range
    Dim MP As MousePoint
    Dim c As Range
    Dim done As Boolean
    Dim olddone As Boolean
    Dim listR As Range
    Dim Target As Range

    DoLoop = True

    Set listR = Range("A20:A29")
    Set Target = Range("A1:C8")

    Do While DoLoop

        If ActiveSheet Is mySh Then     '処理対象シート

            If oldr Is Nothing Then
                Set oldr = Range("A1")      'A20:A29の範囲以外ならどこでもＯＫ
                Target.FormatConditions.Delete
            End If

            GetCursorPos MP

            Set r = ActiveWindow.RangeFromPoint(MP.x, MP.y)
            done = False
            If Not r Is Nothing Then
                If TypeName(r) = "Range" Then
                    If Not Intersect(listR, r) Is Nothing Then
                        done = True
                        If oldr.Address <> r.Address Then
                            Target.FormatConditions.Delete
                            For Each c In Target
                                If c.Value = r.Value Then
                                    c.FormatConditions.Add Type:=xlExpression, Formula1:="=TRUE"
                                    c.FormatConditions(1).Interior.Color = vbRed
                                End If
                            Next
                        End If
                        Set oldr = r
                    End If
                End If
            End If

            If Not done And olddone Then
                    Set oldr = Range("A1")      'A20:A29の範囲以外ならどこでもＯＫ
                    Target.FormatConditions.Delete
            End If

            olddone = done

        End If

        DoEvents
        DoEvents

    Loop

        Target.FormatConditions.Delete

 End Sub

 Private Sub 監視終了()
    MsgBox "マウスポインターの監視を終了します"
    DoLoop = False
 End Sub

 (ぶらっと)

ぶらっとさんが実現してますが、カーソルを合わせただけで動作するのは、
かなり無茶なコーディングなので、簡単に右クリックすると色変えする案。

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim i As Long

    If 1 < Target.Count Then Exit Sub
    If Intersect(Target, Range("A20:A29")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False
    Cancel = True
    Range("A1:C8").Select
    Selection.Interior.ColorIndex = xlNone

    If Target.Value <> "" Then
        For i = 1 To Selection.Count
            If Selection(i).Value = Target.Value Then
                Selection(i).Interior.Color = RGB(255, 192, 192)
            End If
        Next i
    End If

    Target.Select
    Application.ScreenUpdating = True
End Sub
(???)

コメント返信：

[ 一覧(最新更新順) ]

[[20130523120754]] 『セルの色付』（初心者） ページの最後に飛ぶ

[[20130523120754]]　『セルの色付』（初心者）　ページの最後に飛ぶ