別の列のデータを検索してセルの色を変える

質問

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column <> 1) And (Target.Column <> 5) Then Exit Sub
If Not IsNumeric(Target.Value) Then Exit Sub
Target.Offset(0, 1).Value = Now()
End Sub

上記のスクリプトで
「１列目にナンバーを記入すると２列目に、５列目にナンバーを記入すると６列目に時刻が自動的にセルに入る」ようになっています。

これに追加で
「５列目にナンバーが記入されると、そのナンバーと同じものを１列目から探し出して、１列目のセルの色を薄い青にする。なければなしとアラートを出す」
ように改造したいのですが
どうすればいいでしょうか？

どうかお願いいたします。

回答No.5

zap35 · ベストアンサー

#02です。レスポンスありませんね。
複数のセルを同時に更新したり、オートフィルで複数のセルに同時に異なる値をセットしてもそれなりに動くようにしてみました。
セルを空白にしたときの動作などを付け加えましたので多少行数が多くなっていますが、ご参考まで。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim psw1, psw2 As Boolean
Dim rngA, rng, r, trg As Range
　Set rngA = Intersect(Target, Columns(1))
　Set rng = Intersect(Target, Columns(5))
　If rng Is Nothing Then
　　Set rng = rngA
　　If rng Is Nothing Then Exit Sub
　Else
　　If Not rngA Is Nothing Then
　　　Set rng = Application.Union(rngA, rng)
　　End If
　End If
　On Error GoTo end0
　Application.EnableEvents = False
　Application.ScreenUpdating = False
　Columns(1).Interior.ColorIndex = xlNone
　For Each r In rng
　　If r.Value = "" Then
　　　r.Offset(0, 1).ClearContents
　　Else
　　　If IsNumeric(r.Value) Then
　　　　r.Offset(0, 1).Value = Now
　　　　If r.Column = 5 Then
　　　　　psw1 = True
　　　　　Set trg = Columns(1).Find(What:=r.Value, LookIn:=xlValues)
　　　　　If Not trg Is Nothing Then
　　　　　　Set trg = Columns(1).FindPrevious(trg)
　　　　　　trg.Interior.ColorIndex = 24
　　　　　　psw2 = True
　　　　　End If
　　　　End If
　　　End If
　　End If
　Next r
　If (psw1 = True) And (psw2 = False) Then
　　MsgBox "A列に更新数値セルと同じ値はありません"
　End If
end0:
　Application.EnableEvents = True
　Application.ScreenUpdating = True
End Sub

ご質問があれば回答しますが、どこが分からないか具体的に書いていただけると助かります。ただ「解説してください」はご勘弁をm(_ _)m

お礼

ご親切にありがとうございます。
職場で使うものですので運用法など昨日打ち合わせをしました。
ソフトの方に合わせるそうですので使わせていただきます。

本当に深く感謝しております。

回答No.6

zap35

#02です。
もしOffice2007をお使いの場合は、途中のFindメソッドを使っている行を以下に変更してください。（LookAt:=xlWhole　を追加）

Set trg = Columns(1).Find(What:=r.Value, LookIn:=xlValues, lookat:=xlWhole)

回答No.4

imogasi

>同じナンバーが複数あるときは最初だけ水色になるようです。
質問を一読して、複数該当が有るか、質問に書いてないのが気になった。初心者はこれが多い。複数有るなら、もうFind、FindNextが全セル初めから最後まで、その列データを総なめして、各セルの値を探すより無い。
該当が唯一と決まっているなら、１つなら、関数でおなじみの
Sub test01()
x = WorksheetFunction.Match("s", Range("A1:A10"), 0)
MsgBox x
End Sub
のようなのも使えるが。
＞どうすればいいでしょうか？
一部コードも書いているようだから、人に聞く前に、Find、FindNexｔのコードは、検索操作をして、マクロの記録を取り、改造することをやるべきだ。そうすれば疑問点は限られたものになる。
ーー
余り熟練者で無いのに、イベントに頼ってコードを書くべきでない。
本件でも元データが変更されたときなど、該当分を元に戻すなどを考えると苦労するよ。元のセルの値は教えてくれない。

回答No.3

xls88

Dim erng As Range

　　　　　　fstAddress = frng.Address
　　　　　　Do
　　　　　　　　frng.Interior.Pattern = xlNone
　　　　　　　　Set frng = .FindNext(frng)
　　　　　　　　If fstAddress <> frng.Address Then
　　　　　　　　　　Set erng = frng
　　　　　　　　End If
　　　　　　Loop While fstAddress <> frng.Address
　　　　　　erng.Interior.colorIndex = 33

お礼

ありがとうございます。
同僚の仕事の管理が煩雑になっていまして
していただいたご回答で助かると思います。

ポイントに差が付いてしまいましたが
20差し上げたかったです。

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

回答No.2

zap35

複数のセルが同時に更新された場合はどうすればよいですか？
特にオートフィルで複数のセルに異なる値が１回の操作で入力されたらどうなるのが正解なのでしょう？？

深く考えると色々難しくなるので、とりあえず複数のセルが更新されたら処理をスキップするようにしてみました。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cnt As Long
Dim trg As Range
　If Target.Cells.Count > 1 Then
　　MsgBox "複数のセルが同時に更新されました"
　Else
　　If IsNumeric(Target.Value) Then
　　　On Error GoTo end0
　　　Application.EnableEvents = False
　　　Select Case Target.Column
　　　Case Is = 1
　　　　Target.Offset(0, 1).Value = Now()
　　　Case Is = 5
　　　　Target.Offset(0, 1).Value = Now()
　　　　cnt = WorksheetFunction.CountIf(Columns(1), Target.Value)
　　　　If cnt > 0 Then
　　　　　Set trg = Columns(1).Find(What:=Target.Value, LookIn:=xlValues, lookat:=xlWhole)
　　　　　For idx = 1 To cnt
　　　　　　If idx = cnt Then
　　　　　　　Columns(1).Interior.ColorIndex = xlNone
　　　　　　　trg.Interior.ColorIndex = 24
　　　　　　End If
　　　　　　Set trg = Columns(1).FindNext(trg)
　　　　　Next idx
　　　　Else
　　　　　MsgBox "A列に同じ値はありません"
　　　　End If
　　　End Select
　　End If
　End If
end0:
　Application.EnableEvents = True
End Sub

回答No.1

xls88

下記のようなことでどうでしょうか。

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim frng As Range

　　If (Target.Column <> 1) And (Target.Column <> 5) Then Exit Sub
　　If Not IsNumeric(Target.Value) Then Exit Sub
　　Target.Offset(0, 1).Value = Now()
　　If Target.Column = 5 Then
　　　　With Columns("A:A")
　　　　　　Set frng = .Find(Target.Value, .Cells(.Count), xlValues)
　　　　End With
　　　　If frng Is Nothing Then
　　　　　　MsgBox "Not Found!", vbExclamation
　　　　Else
　　　　　　frng.Interior.colorIndex = 33
　　　　End If
　　End If
End Sub

補足

さっそくありがとうございます。

見てみましたが
同じナンバーが複数あるときは最初だけ水色になるようです。
同じナンバーが複数ある時は最後というか一番下にだけ水色にするようにしたいです。

どうかお願いいたします。