Option Explicit
Public Sub 指定行削除()
Dim ws1 As Worksheet '対象項目
Dim ws2 As Worksheet '対象シート
Dim lastRow1 As Long '対象項目 最終行
Dim lastRow2 As Long '対象シート 最終行
Dim row1 As Long '対象項目 行番号
Dim row2 As Long '対象シート 行番号
Dim del_dict As Object '削除対象のキー(種類No)
Dim undel_dict As Object '削除対象外のキー(種類No+名称No)
Dim key1 As String '種類No
Dim key2 As String '種類No+名称No
Set ws1 = Worksheets("対象項目")
Set ws2 = Worksheets("対象シート")
Set del_dict = CreateObject("Scripting.Dictionary")
Set undel_dict = CreateObject("Scripting.Dictionary")
lastRow1 = ws1.Cells(Rows.count, "A").End(xlUp).Row '対象項目の最終行取得
lastRow2 = ws2.Cells(Rows.count, "A").End(xlUp).Row '対象シートの最終行取得
'対象項目を最終行まで検索
For row1 = 3 To lastRow1
'種類Noが空白でないなら
If ws1.Cells(row1, "A").Value <> "" Then
'種類Noを削除対象のキーとする
key1 = ws1.Cells(row1, "A").Value
del_dict(key1) = True
'名称Noが空白でないなら、種類No+名称Noを削除対象外のキーとする
If ws1.Cells(row1, "C").Value <> "" Then
key2 = key1 & "|" & ws1.Cells(row1, "C").Value
undel_dict(key2) = True
End If
End If
Next
'対象シートを最終行から2行まで処理する
For row2 = lastRow2 To 2 Step -1
key1 = ws2.Cells(row2, "A").Value
key2 = key1 & "|" & ws2.Cells(row2, "C").Value
'種類Noが削除対象となっていて
If del_dict.exists(key1) = True Then
'種類No+名称Noが削除対象外となっていないなら
If undel_dict.exists(key2) = False Then
'当該行を削除する
ws2.Rows(row2).Delete
End If
End If
Next
MsgBox ("完了")
End Sub