[[20210807101825]]　『G列が「空白」、かつ、Ｂ列の番号が重複の場合、煤x（シトラス）　ページの最後に飛ぶ

『G列が「空白」、かつ、Ｂ列の番号が重複の場合、背景色をつける』（シトラス）

VBA全くの初心者です。
やりたいことは、G列が空白の行を対象に、B列の重複をチェックすることです。

・完了日（G列）に値が入っていない行のみを対象にする
・項番（B列）の重複番号の背景色を変えたい
（未完了の項番のダブりを見える化したい）

イメージはこのような事がやりたいです　↓

項番（B列）　　　　　　　　　　完了日（G列）
He101 ←（対象外）　　　　　　2021/8/6
Re102 ←（対象外）　　　　　　2021/8/6
He101 ←（対象外）　　　　　　2021/8/6
He101 ←★重複
Re101 ←（対象外）　　　　　　2021/8/6
He101 ←★重複
He101 ←★重複
Re101 ←（対象外）　　　　　　2021/8/6
Re102 ←★重複
Re102 ←★重複

重複チェックの部分は問題なく動作したことを確認出来ていますが、
完了日（G列）が入っている重複にも反応していしまいます。
完了日（G列）が空白な場合という条件を入れたく、
「If Range("G6", Range("G" & Rows.Count).End(xlUp)) = "" Then 」
と入れたところ、上記の場所で「型が一致しません」と出てしまいました。
単純なことなのかもしれませんが…数週間前にVBAを自力で始めたばかりで理解が追い付きませんでした。
皆さんのお力をお借りしたく…宜しくお願いいたします。

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

Dim DicName As Variant
Dim DicColor As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim Q As Long
Dim GetName As String
Dim myKey As Variant
Dim myList As Variant

With Target

'---------------------------------------------------------------------
'連想配列
Set DicName = CreateObject("Scripting.Dictionary")
Set DicColor = CreateObject("Scripting.Dictionary")

If Range("G6", Range("G" & Rows.Count).End(xlUp)) = "" Then 'G6～最終行まで空白があったら実行する

    myList = Range("B1", Range("B" & Rows.Count).End(xlUp)) 'B列のデータを配列に格納

    '配列をループ
    For i = 6 To UBound(myList)                             'iが6行目～myListの最大値まで繰り返す
        GetName = Cells(i, 2)                               'B列を変数に格納

        If Not DicName.Exists(GetName) Then                 '重複しないリストを連想配列へ
            DicName.Add GetName, GetName
        Else
           If Not DicColor.Exists(GetName) Then             '重複しているリストを連想配列へ（色付け対象のリスト）
                 DicColor.Add GetName, GetName
            End If
        End If
    Next i

    myKey = DicColor.keys
    Q = 20

    For i = 0 To UBound(DicColor.items)                     '重複しているリストをループ
        For j = 6 To UBound(myList)                         'セルB6から最終行の回数分ループ
            If Cells(j, 2) = myKey(i) Then
                    Cells(j, 2).Interior.Color = RGB(0, 50 + Q, 100 + Q)    'セルを色付け
            End If
        Next j
    Q = Q + 60
    Next i

    Set DicName = Nothing
    Set DicColor = Nothing

End If
'--------------------------------------------------------------------

End With

End Sub

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

 こんにちは！
 ご提示のコードを最大限尊重するとして、これを↓
 >If Cells(j, 2) = myKey(i) Then

 これに↓したらどうでしょうか？
If (Cells(j, 2) = myKey(i)) * (Cells(j, 7) = "") Then

 あっ、当然これ↓はやめて、、です。
 >If Range("G6", Range("G" & Rows.Count).End(xlUp)) = "" Then 'G6～最終行まで空白があったら実行する
（SoulMan） 2021/08/07(土) 17:20

 すみません。
取得するときも制限を掛けないとだめでした。m(__)m

 Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DicName As Variant
Dim DicColor As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim Q As Long
Dim GetName As String
Dim myKey As Variant
Dim myList As Variant
With Target
'---------------------------------------------------------------------
'連想配列
Set DicName = CreateObject("Scripting.Dictionary")
Set DicColor = CreateObject("Scripting.Dictionary")
'If Range("G6", Range("G" & Rows.Count).End(xlUp)) = "" Then 'G6～最終行まで空白があったら実行する
    myList = Range("B1", Range("B" & Rows.Count).End(xlUp)) 'B列のデータを配列に格納
    '配列をループ
    For i = 6 To UBound(myList)                             'iが6行目～myListの最大値まで繰り返す
        If Cells(i, 7) = "" Then
            GetName = Cells(i, 2)                               'B列を変数に格納
            If Not DicName.Exists(GetName) Then                 '重複しないリストを連想配列へ
                DicName.Add GetName, GetName
            Else
               If Not DicColor.Exists(GetName) Then             '重複しているリストを連想配列へ（色付け対象のリスト）
                     DicColor.Add GetName, GetName
                End If
            End If
        End If
    Next i
    myKey = DicColor.keys
    Q = 20
    For i = 0 To UBound(DicColor.items)                     '重複しているリストをループ
        For j = 6 To UBound(myList)                         'セルB6から最終行の回数分ループ
            If (Cells(j, 2) = myKey(i)) * (Cells(j, 7) = "") Then
                    Cells(j, 2).Interior.Color = RGB(0, 50 + Q, 100 + Q)    'セルを色付け
            End If
        Next j
    Q = Q + 60
    Next i
    Set DicName = Nothing
    Set DicColor = Nothing
'End If
'--------------------------------------------------------------------
End With
End Sub
（SoulMan） 2021/08/07(土) 17:47

 ＞If Range("G6", Range("G" & Rows.Count).End(xlUp)) = "" Then 'G6～最終行まで空白があったら実行する

 それって、G列の最終行番号迄ですよ。

 B列の最終行番号迄じゃないと、マズくないですか？

（半平太） 2021/08/07(土) 20:08

条件付き書式を使ってみてはどうでしょうか？
例えばこんな感じ。

    Sub さんぷる()
        Dim 行 As Long

        With ActiveSheet
            行 = .Cells(.Rows.Count, "B").End(xlUp).Row
            If 行 < 6 Then Exit Sub

            With .Range("B6:B" & 行)
                .FormatConditions.Delete
                .FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIFS(" & .Address & ",B6," & .Offset(, 5).Address & ","""")*(G6="""")>1"
                .FormatConditions(1).Interior.Color = vbYellow
            End With
        End With
    End Sub

（もこな２） 2021/08/07(土) 21:42

SoulManさん、有難うございます！ご提案通りにしたら実現しました！
半平太さん、仰る通りです…！G列は空白になることが多いので…漏れてしまうところでした。

実現したところで問題に気づいてしまったのですが。
重複していた！と気づいた時に、以下のようなことをします。

1 完了日を入れ忘れていた ⇒ 完了日を入れて対象外になる ⇒ 無色になる
2 AB列の項番を消す ⇒ 空白になる ⇒ 無色になる

無色になったら再度重複チェックをしたいので「GoTo Label1」で
重複チェックに飛ばしたつもりなのですが、
一度「重複」の背景色がついたものが無色にならずに困っています。
飛ばし場所が間違っているのでしょうか…。

A| 項番（B列）　　　　　　　　　　完了日（G列）
1| Re101 ←（対象外）　　　　　　2021/8/6
2| Re102 ←★重複
3| Re102 ←★重複　←※B3を削除すると、B2の「Re102」の背景色がそのまま残ってしまいます

↓↓↓　書き換えました。念のため前回からの変更箇所に★印を付けています。

 Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim DicName As Variant
Dim DicColor As Variant
Dim i As Long
Dim j As Long
Dim Q As Long
Dim GetName As String
Dim myKey As Variant
Dim myList As Variant

With Target

'連想配列
Set DicName = CreateObject("Scripting.Dictionary")
Set DicColor = CreateObject("Scripting.Dictionary")

If Cells(Target.Row, 7) <> "" Then '★1 G列の完了日に日付が入ったら

    Cells(Target.Row, 2).Interior.Color = xlNone            '★1 B列の項番は背景色をなしにする
End If
If Cells(Target.Row, 2) = "" Then                           '★2 AB列のターゲットが空白だったら
    Cells(Target.Row, 2).Interior.Color = xlNone            '★2 AB列のターゲットの背景色をなしにする
    GoTo Label1                                             '★2 ALabel1へ
Else
Label1:                                                     '★2ALabel1
    myList = Range("B1", Range("B" & Rows.Count).End(xlUp)) 'B列のデータを配列に格納
    '配列をループ
    For i = 6 To UBound(myList)                             'iが6行目～myListの最大値まで繰り返す
        If Cells(i, 7) = "" Then                            'G列が空白だったら
            GetName = Cells(i, 2)                           'B列を変数に格納
            If Not DicName.Exists(GetName) Then             '重複しないリストを連想配列へ
                DicName.Add GetName, GetName
            Else
                If Not DicColor.Exists(GetName) Then        '重複しているリストを連想配列へ（色付け対象のリスト）
                    DicColor.Add GetName, GetName
                End If
            End If
        End If
    Next i
    myKey = DicColor.keys
    Q = 20

    For i = 0 To UBound(DicColor.items)                     '重複しているリストをループ
        For j = 6 To UBound(myList)                         'セルB6から最終行の回数分ループ
            If (Cells(j, 2) = myKey(i)) * (Cells(j, 7) = "") Then       '★mykeyでG列が空白だったら
                Cells(j, 2).Interior.Color = RGB(0, 50 + Q, 100 + Q)    'セルを色付け
            End If
        Next j
    Q = Q + 60
    Next i

    Set DicName = Nothing
    Set DicColor = Nothing

End If
End With
End Sub

すみません、アドバイスをお願いします。

アッ…もこな２さん、すみません;;
記事書いている間にアドバイス有難うございます。
あああ…こんなスッキリした構文がかけるのですね…！！
（シトラス） 2021/08/07(土) 21:48

 ちょっとというかぁ、、全然、見てませんけど、、初期化が出来ていないだけだと思いますよ？
最初のこの↓したあたりに
Set DicColor = CreateObject("Scripting.Dictionary")
これを入れてみてはどうでしょうか？
Range("B1", Range("B" & Rows.Count).End(xlUp)).Interior.Color = xlNone
（SoulMan） 2021/08/07(土) 22:02

SoulManさん
ありがとうございます！！！
勉強になります…こういうのがパパっとわかるようになりたいです！

もこな２さん
もこな２さんの構文も実現できました！
FormatConditions…知りませんでした。勉強になります。

半平太さん
いつも有難うございます。
（実は関数の時に過去何度かお世話になっております…感謝…！！）
（シトラス） 2021/08/07(土) 22:13

もこな２さんの構文について、後学のために教えて下さい。

=COUNTIFS(" & .Address & ",B6," & .Offset(, 5).Address & ","""")*(G6="""")>1"

重複をカウントしている大事なところだと思っています。

■質問１
「" & .Address &」というのは何を指しているのでしょうか、
「.」はwithで指定した範囲だと理解していますが（間違っていたらツッコミみお願いします）
Addressが良く分かっていません。

■質問２
「""""」ダブルクオーテーションが４つ並んだ状態は「空白」という意味でしょうか？

（シトラス） 2021/08/08(日) 15:27

先に書いたように、条件付き書式の設定をマクロでしてるだけですから、聞く前に【マクロの記録】で調べてみるとか、分からないキーワードをネット検索してみてはどうでしょうか？

＞「.」はwithで指定した範囲だと理解していますが（間違っていたらツッコミみお願いします）
あってます。
【Withステートメント】
http://officetanaka.net/excel/vba/beginner/16.htm

＞■質問１
【Addressプロパティ】
https://www.moug.net/tech/exvba/0050094.html
https://excel-ubara.com/excelvba1/EXCELVBA384.html
https://docs.microsoft.com/ja-jp/office/vba/api/excel.range.address

＞■質問２
http://officetanaka.net/excel/vba/tips/tips90.htm

（もこな２） 2021/08/08(日) 17:10

もこな２さん、
マクロの記憶は試してみたのですが…何故か同じ結果にならず、
検索ワードに入れるキーワードが適格ではなかったようで…目的のサイトに辿り着けませんでした。

数週間前に初心者向けのVBAの本を買って読み始めたばかりでして、
出てくる単語の一語一句を理解するのも、人の何倍もかかっており…。
つい…あてにしてしまいました。不愉快な想いをさせてしまい申し訳ありませんでした。

ご丁寧に教えて下さりありがとうございます。
目を通して理解を深めていきます。
ありがとうございました。
（シトラス） 2021/08/08(日) 20:15

コメント返信：

[ 一覧(最新更新順) ]

[[20210807101825]] 『G列が「空白」、かつ、Ｂ列の番号が重複の場合、煤x（シトラス） ページの最後に飛ぶ

[[20210807101825]]　『G列が「空白」、かつ、Ｂ列の番号が重複の場合、煤x（シトラス）　ページの最後に飛ぶ