[[20170811080348]]　『リストにある2列ずつのデータが　不一致の物を探ａx（ゆう）　ページの最後に飛ぶ

『リストにある2列ずつのデータが　不一致の物を探したい』（ゆう）

投稿
[[20101113104924]] 『２列ずつのデータが一致した場合に色をつける』（キム）　
について...

過去の質問を検索させて頂いている中で、上記内容が近いと思ったのですが・・・色々探してみたのですが、自分の知識では解決できませんでした。

以下がレイアウトです
シート1

    |   A    |   B   |   C    |   D   　　　　　|   E    |  F   |・・
 01 | 　A　  |  あ   |   A        い　←質問2のみエラー　
 02 |   B    |  い   |   A　　　　あ　
 03 |   C    |  う   |　 　 　　　 う　←質問1、2ともにエラーではない
 04 |   D    |  え   |   Z      　　　←質問1、2ともにエラー
 05 |   E    |  お   | 　B      　う　←質問2のみエラー
 06 |   F    |  か   |           　　←質問1、2ともエラーではない

シート2

    |   A    |   B   |  
 01 | 　A　  |  あ   | 
 02 |   B    |  い   | 
 03 |   C    |  う   | 
 04 |   D    |  え   | 
 05 |   E    |  お   | 
 06 |   F    |  か   |

２点行いたいことがあるのですが、ご教授お願いします。
1点目は、シート2のA列の中にある文字列（1000行くらい）以外が、
シート1の奇数列（A,C、E、・・・・）にあれば、シート1の該当するセルのみの背景色を茶色にしたい。ただし、シート1の奇数列が空白の場合は、処理しない。

2点目は、シート2のA列とB列の中にある文字列がA1= B1,A2=B2、C3=D3、…のように、2列のセットで不一致の文字列が、
シート1にあればその該当する二つのセルにのみ、背景色を青色にしたい。ただし、シート1の二つのセルともに空白の場合は、処理しない。片方だけ文字列があった場合には二つのセルとも背景色を青色にしたい。

どうかよろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：WindowsXP ＞

一点訂正させてください。
シート1

    |   A    |   B   |   C    |   D   　　　　　|   E    |  F   |・・
 03 |   C    |  う   |　 　 　　　 う　←質問1、2ともにエラーではない
→上記の箇所の質問1，2ともにエラーではない。　→正しくは質問1はエラーではない。質問2はエラーです
（ゆう） 2017/08/11(金) 09:11

 A1からデータが始まる場合を想定しています。
 A1以外から（B2等）からデータが始まる場合は、別途調整が必要です。

 条件についてですが、提示の例だと、茶色になるところありませんよね？
 C4:D4は条件2が優先されるので、茶色→青に塗り替えで合っていますか？

    Option Explicit

    Sub test()
        Dim vData As Variant
        Dim vList As Variant
        vData = Sheets("Sheet1").Range("A1").CurrentRegion.Value '★
        vList = Sheets("Sheet2").Range("A1").CurrentRegion.Value '★

        '[必須]参照設定　MicrosoftScriptingRuntime
        Dim dic(1) As Dictionary
        Set dic(0) = New Dictionary
        Set dic(1) = New Dictionary

        Dim ir As Long
        For ir = 1 To UBound(vList, 1)
            dic(0)(vList(ir, 1)) = ""
            dic(1)(vList(ir, 1) & vList(ir, 2)) = ""
        Next ir

        Dim ic As Long
        Dim rColor(1) As Range
        Dim ID As String
        For ic = 1 To UBound(vData, 2) Step 2 '奇数
            For ir = 1 To UBound(vData, 1)
                '//条件1
                ID = vData(ir, ic)
                If ID <> "" And Not dic(0).Exists(ID) Then
                    Set rColor(0) = SetColorRange(rColor(0), Sheets("sheet1").Cells(ir, ic)) '★
                End If

                '//条件2
                ID = vData(ir, ic) & vData(ir, ic + 1)
                If ID <> "" And Not dic(1).Exists(ID) Then
                    Set rColor(1) = SetColorRange(rColor(1), Sheets("sheet1").Range(Cells(ir, ic), Cells(ir, ic + 1))) '★
                End If
            Next ir
        Next ic
        Sheets("Sheet1").Cells.Interior.ColorIndex = xlNone
        If Not rColor(0) Is Nothing Then
            rColor(0).Interior.Color = RGB(153, 51, 0) '茶色
        End If
        If Not rColor(1) Is Nothing Then
            rColor(1).Interior.Color = vbBlue
        End If
        Set dic(0) = Nothing
        Set dic(1) = Nothing
        Set rColor(0) = Nothing
        Set rColor(1) = Nothing
    End Sub

    Function SetColorRange(ByVal rng As Range, ByVal Inputrng As Range) As Range
        If rng Is Nothing Then
            Set SetColorRange = Inputrng
        Else
            Set SetColorRange = Union(rng, Inputrng)
        End If
    End Function
（稲葉） 2017/08/11(金) 10:19

稲葉様
ありがとうございます。外出中の為、色々試させて頂いきたいです。後ほど報告させて頂きます。

条件2 C4:D4は条件2が優先されるので、茶色→青に塗り替えで合っていますか？
あっ！！条件2が優先であれば、確かに、茶色になるところありません。あっています。

すみませんでした。私の想定ミスです。条件2だけで問題ないです。

（ゆう） 2017/08/11(金) 10:45

 ・・・ですよね。
 条件１が成立する場合、条件２は必ず成立ですもんね。

 いかに差し替えでお願いします。
    Option Explicit

    Sub test()
        Dim wsData As Worksheet
        Set wsData = Sheets("Sheet1") '★

        Dim vData As Variant
        Dim vList As Variant
        vData = wsData.Range("A1").CurrentRegion.Value '★
        vList = Sheets("Sheet2").Range("A1").CurrentRegion.Value '★

        '[必須]参照設定　MicrosoftScriptingRuntime
        Dim dic As Dictionary
        Set dic = New Dictionary

        '//辞書の作成　Aあ　Bい・・・
        Dim ir As Long
        For ir = 1 To UBound(vList, 1)
            dic(vList(ir, 1) & vList(ir, 2)) = ""
        Next ir

        Dim ic As Long
        Dim rColor As Range
        Dim ID As String
        For ic = 1 To UBound(vData, 2) Step 2 '奇数列
            For ir = 1 To UBound(vData, 1)
                '//条件2
                ID = vData(ir, ic) & vData(ir, ic + 1) 'ここでインデックスエラーが出たら、表の範囲外に何らかの入力がある
                If ID <> "" And Not dic.Exists(ID) Then
                    If rColor Is Nothing Then
                        Set rColor = wsData.Range(Cells(ir, ic), Cells(ir, ic + 1))
                    Else
                        Set rColor = Union(rColor, wsData.Range(Cells(ir, ic), Cells(ir, ic + 1)))
                    End If
                End If
            Next ir
        Next ic
        wsData.Cells.Interior.ColorIndex = xlNone
        If Not rColor Is Nothing Then rColor.Interior.Color = vbBlue
        Set dic = Nothing
        Set rColor = Nothing
    End Sub
（稲葉） 2017/08/11(金) 11:13

稲葉様　提示して頂いたコードは完璧に動いています。ありがとうございます。

しかしながら、実物で動かしたい表が少し違いまして・・・本当にすみません。
調べながら別途調整をしていましたが、どうも上手くいかなくて困っています。

実物のシート1のレイアウトは
D5：FI35の範囲の中で　、質問と同様にシート2のA1 =B1・・・と続く中の、一致しないものを探したいです。

シート1

    | A | B | C　 | D| E  　｜　| F |G｜・・・
 01 |   |　 |   　|  |　　　｜
 02 |   |   | 　　|  |　　　｜
 03 |   |   |　 　|  |　　　｜　
 04 |   |   |   　|セル結合 ｜セル結合 　と同様に続いています
 05 |   |   |関数 |A |あ　　｜B｜あ｜
 06 |   |   |関数 |C |う　　｜D｜う｜

Sheets("Sheet2").Range("A1").CurrentRegion.Value
上記にて取得する表の範囲は流動的ですが　うまく取得できています。

vData = wsData.Range("A1").CurrentRegion.Value
A1からC4に変更したら、A1:FI36の表範囲を取得していました。

エラー箇所は、ID = vData(ir, ic) & vData(ir, ic + 1) '
ここでインデックスエラーが出たら、表の範囲外に何らかの入力があるとのことでしたが、調整が出来なくて情けない。

D5を起点のセル、終点をFG35にとも考えたのですが、どうも修正がうまくいかないです。
（ゆう） 2017/08/11(金) 20:34

 ＞D5を起点のセル、終点をFG35にとも考えたのですが、どうも修正がうまくいかないです。
 実際の表は2セット4列だけなんですか？
 最終行と最終列が固定であればいいんですが、そうでない場合行・列の最終行を取得する必要があります。

 どのようなデータかわかりませんので、手が出せません。

 もう少し詳しく説明いただけますか？
（稲葉） 2017/08/11(金) 22:13

稲葉様　お手数をおかけしてすみません。
シート1のレイアウトですが、列はDEからFGまで　行は5から35行までの　80セット160列のみで判定できたら
、行いことが実現できます。
最終行と最終列は固定です。

 DE　EF　GH　HI　JK　LM　OP　QR　ST　UV　WX　YZ　AA,AB　BC,CD　・・・　　　FF,FG
5 
6
7
8
9

32
33
34
35

シート2のA列、B列に関しては、200行程度で順次増えていきます。

（ゆう） 2017/08/11(金) 22:46

すみません、DEからFGではなくて、DからFG列です。
上記訂正させてください。
（ゆう） 2017/08/11(金) 22:53

 変更点数か所なのですが、1から書き直さないと非常にわかりにくいコードですね・・・
 急ぎなら下記コード、そうでなければ、時間があるときに書き直します。
 なんかバグありそう

    Option Explicit

    Sub test()
        Dim wsData As Worksheet
        Set wsData = Sheets("Sheet1") '★
        Dim rngData As Range
        Set rngData = wsData.Range("D5:FG35")
        Dim vData As Variant
        Dim vList As Variant
        vData = rngData.Value
        vList = Sheets("Sheet2").Range("A1").CurrentRegion.Value '★
        '[必須]参照設定　MicrosoftScriptingRuntime
        Dim dic As Dictionary
        Set dic = New Dictionary
        '//辞書の作成　Aあ　Bい・・・
        Dim ir As Long
        For ir = 1 To UBound(vList, 1)
            dic(vList(ir, 1) & vList(ir, 2)) = ""
        Next ir
        Dim ic As Long
        Dim rColor As Range
        Dim ID As String
        For ic = 1 To UBound(vData, 2) Step 2 '奇数列
            For ir = 1 To UBound(vData, 1)
                '//条件2
                ID = vData(ir, ic) & vData(ir, ic + 1) 'ここでインデックスエラーが出たら、表の範囲外に何らかの入力がある
                If ID <> "" And Not dic.Exists(ID) Then
                    If rColor Is Nothing Then
                        Set rColor = rngData.Range(Cells(ir, ic), Cells(ir, ic + 1))
                    Else
                        Set rColor = Union(rColor, rngData.Range(Cells(ir, ic), Cells(ir, ic + 1)))
                    End If
                End If
            Next ir
        Next ic
        wsData.Cells.Interior.ColorIndex = xlNone
        If Not rColor Is Nothing Then rColor.Interior.Color = vbBlue
        Set dic = Nothing
        Set rColor = Nothing
    End Sub
（稲葉） 2017/08/11(金) 22:56

稲葉様　
すごいです。短期間なのに思い描いた通りにできています。本当にありがとうございます。
バグがあるのかは私にはわかりませんが、きちんと作業してくれています。
急ぎではありませんので、もしよろしければ、お時間が許すときに、エラーがある箇所のみ背景色を青になるととてもうれしいです。
現状ではD5:FG35のセルにはあらかじめ背景色があり、コードを実行すると、D35:F35の範囲のエラー以外のすべての背景色が白となり、エラーの箇所のセルの背景色が青になっています。
マクロの記録で、塗りなおせば済む話なのですが。
ありがとうございます。早速の上記コード嬉しい限りです。
（ゆう） 2017/08/11(金) 23:15

 そういう情報は最初に・・・
 これに限ったことではないのですが、何かを変更する場合は、初期値にしてから実行するので
 現状を変えてほしくないのであればそう書いてくれると助かります。

 解決策は
         wsData.Cells.Interior.ColorIndex = xlNone
 をコメントアウトするだけです。
（稲葉） 2017/08/11(金) 23:18

稲葉様　説明が足りなくてすみません。また質問させていただくときは、もう少し詳しく説明させて頂きます。それともう少しVBAの言語を勉強しておきます。お時間をいただいて、ありがとうございました。とても助かりました。
（ゆう） 2017/08/12(土) 00:01

Sheet1>>

		　C	　D	E	F
		ああああ		いいい	
　　　　4	 　A　  あ   	A	い
	5	   B    い   	A	あ
	6	   C    う   		う
	7	   D    え   	Z	
	8	   E    お   	B	う
	9	   F    か

Sheet2>>

Sheet3>>

	       A	B
        1	項目1	項目2
        2	<>	<>

以上のようなシートとして以下のコードでいかがでしょう？

Sub test()

    Dim rngTable As Range       '加工したい表のセル範囲（固定)
    Dim rngList As Range        '検索するキーワード一覧のセル範囲(可変）
    Dim rngException As Range   '例外の条件（公開は空白）のセル範囲
    Dim rngWork As Range        '作業用のセル範囲
    Dim i As Long               '列のインデックス番号

    Set rngTable = Worksheets("Sheet1").Range("C4:F9")
    Set rngList = Worksheets("Sheet2").Range("A1").CurrentRegion
    Set rngException = Worksheets("Sheet3").Range("A1").CurrentRegion

    For i = 1 To rngTable.Columns.Count Step 2
        Set rngWork = rngList.Offset(rngList.Rows.Count + 1)
        rngTable.Columns(i).Resize(, 2).Copy rngWork

        With rngWork.CurrentRegion
            Application.Range(rngList, .Cells).AdvancedFilter _
                    Action:=xlFilterInPlace, _
                    CriteriaRange:=rngException, _
                    Unique:=True

            On Error Resume Next
            .SpecialCells(xlCellTypeVisible).Interior.Color = vbBlue
            On Error GoTo 0
            .Parent.ShowAllData
            .Copy rngTable(1, i)
            .Delete Shift:=xlToLeft
        End With
    Next
End Sub

シート1のセル範囲は固定なのですね？
直せますかね？
って、すでに解決済みだったのかな。。。orz
わかりにくい。。。。
（まっつわん） 2017/08/12(土) 21:59

コメント返信：

[ 一覧(最新更新順) ]

[[20170811080348]] 『リストにある2列ずつのデータが 不一致の物を探ａx（ゆう） ページの最後に飛ぶ

[[20170811080348]]　『リストにある2列ずつのデータが　不一致の物を探ａx（ゆう）　ページの最後に飛ぶ