Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

20609 / 76735

←次へ　｜　前へ→


	【61540】Re:特定のセルと一致すれば色を変える

つん - 09/5/15(金) 15:22 -


	引用なし

	パスワード

どもども

なんとなく、HAMさんのやり方の方がいいかもな？という気もしますが、
（If .Value = Cells(1, 5) Then .Interior.ColorIndex = 7 '
　ここんとこ　　↑Cells(2,5)ですね＾＾）

チロさんが、「Worksheet_Change」でしてはったんで、
それでしてみました。

'==============================================
Private Sub Worksheet_Change(ByVal Target As Range)

　　Dim r As Range
　　Dim r2 As Range
　　
　　Set r2 = Intersect(Target, Range("e2:h2"))
　　'セル色変更入力で重複を防ぐ
　　　　If Not r2 Is Nothing Then
　　　　　　For Each r In Range("e2:h2")
　　　　　　　　If r.Address <> Target.Address And r.Value = Target.Value Then
　　　　　　　　　　MsgBox "値が重複しています"
　　　　　　　　　　Application.EnableEvents = False
　　　　　　　　　　Target.Value = ""
　　　　　　　　　　Application.EnableEvents = True
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　Next r
　　　　End If
　　　　
　　Set r2 = Intersect(Target, Range("j2:l4", "n2:q5"))
　　'文字色変更入力で重複を防ぐ
　　　　If Not r2 Is Nothing Then
　　　　　　For Each r In Range("j2:l4", "n2:q5")
　　　　　　　　If r.Address <> Target.Address And r.Value = Target.Value Then
　　　　　　　　　　MsgBox "値が重複しています"
　　　　　　　　　　Application.EnableEvents = False
　　　　　　　　　　Target.Value = ""
　　　　　　　　　　Application.EnableEvents = True
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　Next r
　　　　End If
　　
　　Select Case Target.Address(0, 0)
　　　　Case "E2"
　　　　　　Call subIroIro(Target, 7, True)
　　　　Case "F2"
　　　　　　Call subIroIro(Target, 46, True)
　　　　Case "G2"
　　　　　　Call subIroIro(Target, 6, True)
　　　　Case "H2"
　　　　　　Call subIroIro(Target, 4, True)
　　　　Case "J2", "J3", "J4", "K1", "K2", "K3", "L2", "L3", "L4"
　　　　　　Call subIroIro(Target, 3, False)
　　　　Case "N2", "N3", "N4", "N5", "O2", "O3", "O4", "O5", "P2", "P3", "P4", "P5", "Q2", "Q3", "Q4", "Q5"
　　　　　　Call subIroIro(Target, 5, False)
　　End Select
　　
　　Set r2 = Nothing
　　
End Sub

'==============================================
Sub subIroIro(arg_rTarget As Range, arg_lngIro As Long, arg_blnFlag As Boolean)
'arg_rTarget　入力したセル
'arg_lngIro　設定する色
'arg_blnFlag　セル(True)か文字(False)か

　　Dim rHit As Range
　　Dim strAddress As String
　　
　　With Range("E11:AH74")
　　
　　　　Set rHit = .Find(arg_rTarget.Value, LookIn:=xlValues, LookAt:=xlWhole)
　　　　
　　　　If Not rHit Is Nothing Then
　　　　　　strAddress = rHit.Address
　　　　　　Do
　　　　　　　　Select Case arg_blnFlag
　　　　　　　　　　Case True
　　　　　　　　　　　　rHit.Interior.ColorIndex = arg_lngIro
　　　　　　　　　　Case False
　　　　　　　　　　　　rHit.Font.ColorIndex = arg_lngIro
　　　　　　　　End Select
　　　　　　　　Set rHit = .FindNext(rHit)
　　　　　　Loop While Not rHit Is Nothing And rHit.Address <> strAddress
　　　　End If
　　
　　End With

End Sub
'==============================================

一応、セル色変更、文字色変更のくくりで重複しないように処理しましたが、
削除された時とか、他にたくさん問題ありそう＾＾；

参考にでもなれば＾＾

0 hits

▼

【61535】特定のセルと一致すれば色を変える チロ 09/5/14(木) 22:40