[[20220317095518]]　『一行ごとに同じ値がないかチェックしてセルに色を』（0108）　ページの最後に飛ぶ

『一行ごとに同じ値がないかチェックしてセルに色を付ける』（0108）

Excelの表に数字や名前がリストで管理されているものがあります。セルに対して複数名記載されているときは、改行で入力されており、行単位で同じ値があればセルに色を付けるようにしたいです。また、値が更新されて重複が解消されればセルの色をなしにしたいです。以下のようにコードを記載したのですが、色の付き方が上手くできません。どのようにしたら良いでしょうか。ご教示願います。

―――――――――――――――――――――――――――――――

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Long, y As Long

    x = Target.Column '列
    y = Target.Row  '行

Dim i As Long, j As Long
Dim ss As Variant
Dim buf As String

For j = 2 To 17
If InStr(Cells(y, x), vbLf) > 0 Then

    ss = Split(Cells(y, x), vbLf)
For i = 0 To UBound(ss)
    buf = ss(i)
    Call myColor(buf, x, y)
Next i
Else
    buf = Cells(y, x)
    Call myColor(buf, x, y)
End If
Next j
End Sub

Sub myColor(ByVal buf As String, ByVal x As Long, ByVal y As Long)
Dim jj As Long
For jj = 2 To 17

    If InStr(Cells(y, x + jj), buf) > 0 Then
        Cells(y, x + jj).Interior.ColorIndex = 6
    Else
        Cells(y, x + jj).Interior.ColorIndex = xlNone
    End If
Next jj
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
Dim x As Long, y As Long

    x = Target.Column '列
    y = Target.Row  '行

Dim i As Long, j As Long
Dim ss As Variant
Dim buf As String

For j = 2 To 17
If InStr(Cells(y, x), vbLf) > 0 Then

    ss = Split(Cells(y, x), vbLf)
For i = 0 To UBound(ss)
    buf = ss(i)
    Call myColor(buf, x, y)
Next i
Else
    buf = Cells(y, x)
    Call myColor(buf, x, y)
End If
Next j
End Sub

Sub myColor(ByVal buf As String, ByVal x As Long, ByVal y As Long)
Dim jj As Long
For jj = 2 To 17

    If InStr(Cells(y, x + jj), buf) > 0 Then
        Cells(y, x + jj).Interior.ColorIndex = 6
    Else
        Cells(y, x + jj).Interior.ColorIndex = xlNone
    End If
Next jj
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

少し修正しましたが、直前までの値を更新したものしか重複チェックができず、良い方法が思いつきません。どのようにしたら良いかアドバイスいただけないでしょうか。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Long, y As Long

    x = Target.Column '列
    y = Target.Row  '行

Dim i As Long, j As Long
Dim ss As Variant
Dim buf As String

If InStr(Cells(x, y), vbLf) > 0 Then

    ss = Split(Cells(x, y), vbLf)
For i = 0 To UBound(ss)
    buf = ss(i)
    Call myColor(buf, x, y)
Next i
Else
    buf = Cells(y, x)
    Call myColor(buf, x, y)
End If
End Sub

Sub myColor(ByVal buf As String, ByVal x As Long, ByVal y As Long)
Dim jj As Long
For jj = 2 To 17

    If InStr(Cells(y, jj), buf) > 0 Then
        Cells(y, jj).Interior.ColorIndex = 6
    Else
        Cells(y, jj).Interior.ColorIndex = xlNone
    End If
Next jj
End Sub
（0108） 2022/03/17(木) 10:42

 >色の付き方が上手くできません。
 「上手くできない」を具体的に説明（AのようになってほしいがBのようになる）してください。
（.:*.ゆ ゅ） 2022/03/17(木) 11:32

（.:*.ゆゅ）さん
コメントありがとうございます。再度以下のように修正したのですが、改行で書かれているセルの値が
同じ行の他のセルと重複してセルの色が変わるはずの箇所が、色が付く⇒色なしとすぐに変更されてしまいます。何がいけないかお分かりになりますでしょうか。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Long, y As Long, n As Long

    x = Target.Column '列
    y = Target.Row  '行

Dim i As Long, j As Long
Dim ss As Variant
Dim buf As String

If InStr(Cells(y, x), vbLf) > 0 Then

    ss = Split(Cells(y, x), vbLf)
For i = 0 To UBound(ss)
    buf = ss(i)
    n = 0
    Call myColor(buf, y, x, n)
    If n = 1 Then
        Exit For
    End If
Next i
Else
    buf = Cells(y, x)
    Call myColor(buf, y, x, n)
End If
End Sub

Sub myColor(ByVal buf As String, ByVal y As Long, ByVal x As Long, n As Long)
Dim jj As Long

For jj = 2 To 17

    If InStr(Cells(y, jj), buf) > 0 Then
        Cells(y, x).Interior.ColorIndex = 6
        n = 1
    Else
        Cells(y, x).Interior.ColorIndex = xlNone
    End If
Next jj
End Sub

（0108） 2022/03/17(木) 11:55

 何かもっときれいなコードになりそうな気もしますが、とりあえず。

 Private Sub Worksheet_Change(ByVal Target As Range)
     Dim x As Long, y As Long
     x = Target.Column    '列
     y = Target.Row  '行
     Dim i As Long, j As Long
     Dim ss As Variant
     Dim buf As String
     Dim r As Range

     Call myColorReset(y)
     For Each r In Cells(Target.Row, 2).Resize(1, 16)
         If r.Value <> "" Then
             If InStr(r.Value, vbLf) > 0 Then
                 ss = Split(r.Value, vbLf)
                 For i = 0 To UBound(ss)
                     buf = ss(i)
                     Call myColor(buf, r)
                 Next i
             Else
                 buf = r.Value
                 Call myColor(buf, r)
             End If
         End If
     Next
 End Sub
 Sub myColorReset(y As Long)
     Cells(y, 2).Resize(1, 16).Interior.ColorIndex = xlNone
 End Sub
 Sub myColor(ByVal buf As String, ByVal r As Range)
     Dim jj As Long
     Dim x As Long, y As Long
     x = r.Column
     y = r.Row
     For jj = 2 To 17
         If jj <> x Then
             If Cells(y, jj) <> "" Then
                 If InStr(Cells(y, jj), buf) > 0 Then
                     Cells(y, jj).Interior.ColorIndex = 6
                     Cells(y, x).Interior.ColorIndex = 6
                 End If
             End If
         End If
     Next jj
 End Sub

（γ） 2022/03/17(木) 12:02

（γ）さん

実現したいことができました！ありがとうございます！！

何かもっときれいなコードになりそうな気もしますが、とりあえず。
↑私からしたらとてもすっきりしたものとなり、大変勉強になりました。

今回は本当に助かりました。これからも（γ）さんのようなコードが書けるよう日々勉強したいと思います。
（0108） 2022/03/17(木) 12:19

 元のコードから離れて考えると、こんな感じでも対応できます。

 Private Sub Worksheet_Change(ByVal Target As Range)
     Dim dic As Object
     Dim y As Long
     Dim r As Range
     Dim ary As Variant
     Dim e  As Variant
     Dim cols As Variant
     Dim s As Variant
     Dim k As Long

     Set dic = CreateObject("Scripting.Dictionary")
     y = Target.Row

     'その行の色をいったん消去
     Cells(y, 2).Resize(1, 16).Interior.ColorIndex = xlNone

     '各文字列要素が何列目にあるかをdictionaryに保持
     For Each r In Cells(Target.Row, 2).Resize(1, 16)
         If r.Value <> "" Then
             ary = Split(r.Value, vbLf)
             For Each s In ary
                 dic(s) = dic(s) & r.Column & ","
             Next
         End If
     Next

     '二か所以上にあれば、それらのセルに色を付ける
     For Each e In dic
         cols = Split(dic(e), ",")
         If UBound(cols) > 1 Then
             For k = 0 To UBound(cols) - 1
                 Cells(y, CLng(cols(k))).Interior.ColorIndex = 6
             Next
         End If
     Next
 End Sub

（γ） 2022/03/17(木) 13:03

（γ）さん

さらにアドバイスいただきありがとうございます。
こちらの方法でも実現できました。やはりdictionaryを使用するのが簡潔で良いですね。

因みにだったのですが、初めにお教えいただきましたコードを完全一致にするにはどのようにしたら良いでしょうか。InStrでの検索方法しかわからず、もしよろしければアドバイスいただけますと幸いです。
（0108） 2022/03/17(木) 13:11

すみません、自己解決できました。初歩的な質問ばかりで申し訳ございませんでした。
今回は本当に助かりました。また機会がありましたらよろしくお願いします。
（0108） 2022/03/17(木) 14:32

コメント返信：

[ 一覧(最新更新順) ]

[[20220317095518]] 『一行ごとに同じ値がないかチェックしてセルに色を』（0108） ページの最後に飛ぶ

[[20220317095518]]　『一行ごとに同じ値がないかチェックしてセルに色を』（0108）　ページの最後に飛ぶ