昨日のご教授頂いたVBAプログラムについて

昨日、VBAを使ってエクセルのシートA（仮名）とシートB（仮名）でシートAの1列目（氏名）、3列目（勤怠項目）、4列目（日付）の3項目がシートBにマッチングするものはシートBの氏名にカラーを塗りつぶしていただくという依頼をしました。

下記のコードを教えて頂き結果もＯＫで大満足です。
しかし今後のことも考慮して自分でもマッチングできるようにコードを分析していたのですが、どのコードの部分でシートAとシートＢの複数項目がマッチングしているかを判定しているのかが未だわかりません。

すみませんが下記コードが上記になるのですが教えて頂けますでしょうか。
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・


Sub Sample1()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myR

　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("シートA")
　　　Application.ScreenUpdating = False
　　　　With Worksheets("シートB")
　　　　　.Range("A:A").Interior.ColorIndex = xlNone
　　　　　　lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(lastRow, "D"))
　　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 3) & "_" & myR(i, 4)
　　　　　　　　　　If Not myDic.exists(myStr) Then '//←念のため//
　　　　　　　　　　　myDic.Add myStr, ""
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　　.Range("I:I").Insert
　　　　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "I"))
　　　　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 3) & "_" & myR(i, 4)
　　　　　　　　　　　　If myDic.exists(myStr) Then
　　　　　　　　　　　　　If myR(i, 8) = "" Then
　　　　　　　　　　　　　　myR(i, 9) = 1
　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　myR(i, 9) = 2
　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　Next i
　　　　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "I")) = myR
　　　　　　　　　　With .Range("A1")
　　　　　　　　　　　.AutoFilter field:=9, Criteria1:=1
　　　　　　　　　　　　If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
　　　　　　　　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "A")).SpecialCells(xlCellTypeVisible).Interior.Color = RGB(0, 255, 0) '//黄緑?//
　　　　　　　　　　　　End If
　　　　　　　　　　　.AutoFilter field:=9, Criteria1:=2
　　　　　　　　　　　　If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
　　　　　　　　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "A")).SpecialCells(xlCellTypeVisible).Interior.Color = RGB(0, 255, 255) '//水色?//
　　　　　　　　　　　　End If
　　　　　　　　　　End With
　　　　　　　　　　　.AutoFilterMode = False
　　　　　　　　　　　.Range("I:I").Delete
　　　　Set myDic = Nothing
　　　　.Activate
　　End With
　　　Application.ScreenUpdating = True
　　　　MsgBox "完了"
End Sub

No.1 回答者： GooUserラック 回答日時： 2019/10/14 18:52

前回の質問の No.3 ですが、色が付かなかったのは とますとます さんが設定をカスタマイズされていなかったせいだと思います。

以下の部分の数字を環境に合わせて実行してみて下さい。
（定数や変数の意味は日本語にわざわざしたので判るとは思いますが判らなければ言ってください）

　Const Str_元シート As String = "シートA"
　Const Lng_元始行 As Long = 2
　Const Lng_元氏名列 As Long = 1
　Const Lng_元勤怠列 As Long = 3
　Const Lng_元日付列 As Long = 4
　Const Str_先シート As String = "シートB"
　Const Lng_先始行 As Long = 2
　Const Lng_先氏名列 As Long = 7
　Const Lng_先勤怠列 As Long = 9
　Const Lng_先日付列 As Long = 10
　Const Lng_先確認列 As Long = 14

　　Lng_黄緑色 = RGB(204, 255, 204)
　　Lng_青色 = RGB(0, 0, 255)

この回答へのお礼

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

お礼日時：2019/10/15 15:29

No.2 ベストアンサー 回答者： tom04 回答日時： 2019/10/14 23:05

こんばんは！

前回回答した者です。

コードの流れを少しだけ説明します。
「シートB」が約5000のデータ数だというコトだったと思いますので、
単純にループさせるとそこそこ時間を要すると思い、配列で操作しています。
配列内でループさせると格段に速くなります。
（シートAの方は配列にしなくてもよいのですが、シートAも配列で処理しています）

①　シートAの2行目～最終行のA・C・D列をアンダーバーで連結させたデータを
一旦「辞書」（myDic）に登録しておきます。
＞myStr = myR(i, 1) & "_" & myR(i, 3) & "_" & myR(i, 4)
が　A・C・D列を「_」で連結した文字列になります。

②　シートBのI列を挿入し、I列を作業用の列として使っています。

そしてシートBのA2～A列最終行、I列までをmyRの配列に格納し同様に
＞myStr = myR(i, 1) & "_" & myR(i, 3) & "_" & myR(i, 4)
で　A・C・D列を連結させたデータがシートAにあるかどうかを判断。
シートAに存在する場合（辞書に登録されている場合）はH列の入力の有無を判断
H列に入力がない場合はI列に「1」を！
H列に入力がある場合はI列に「2」を表示！

If myDic.exists(myStr) Then
　If myR(i, 8) = "" Then
　　myR(i, 9) = 1
　Else
　　myR(i, 9) = 2
　End If
End If

の部分がそれにあたります。

最後にオートフィルタでI列をキーとして
「1」で絞り込み　→　表示されているA列の塗りつぶしを「黄緑」
「2」で絞り込み　→　表示されているA列の塗りつぶしを「水色」

としています。

※　最初の書いたように時間短縮のためにオートフィルタで一気に色付けをしています。
もちろん1行ずつ検索してもよいのですが、結構時間を要すると思ったために
配列で処理してみました。

※　配列で処理すると数万行でデータもほとんど時間を要しないと思います。

こんな感じでよろしいでしょうかね。m(_ _)m