Sub test()
Dim a, b, e, i As Long, w, dic As Object, dic2 As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("exclusion table").Cells(1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Trim$(a(i, 1)) <> "" Then dic(a(i, 1)) = Empty
Next
a = Sheets("search table").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If a(i, 1) <> "" Then .Item(a(i, 1)) = .Item(a(i, 1)) & ", " & a(i, 2)
Next
a = Sheets("database").Cells(1).CurrentRegion
Set dic2 = CreateObject("Scripting.Dictionary")
ReDim b(1 To UBound(a, 1), 1 To 4)
For i = 2 To UBound(a, 1)
dic2.RemoveAll
If .exists(a(i, 3)) Then
For Each e In Split(.Item(a(i, 3)), ", ")
If e <> "" Then
If Not dic2.exists(e) Then dic2(e) = Empty
End If
If dic.exists(e) Then b(i - 1, 4) = b(i - 1, 4) & _
IIf(b(i - 1, 4) <> "", ", ", "") & e
Next
b(i - 1, 1) = Mid$(.Item(a(i, 3)), 3)
End If
If .exists(a(i, 4)) Then
For Each e In Split(.Item(a(i, 4)), ", ")
If dic2.exists(e) Then b(i - 1, 3) = b(i - 1, 3) & _
IIf(b(i - 1, 3) <> "", ", ", "") & e
If dic.exists(e) Then b(i - 1, 4) = b(i - 1, 4) & _
IIf(b(i - 1, 4) <> "", ", ", "") & e
Next
b(i - 1, 2) = a(i, 4) & ", " & Mid$(.Item(a(i, 4)), 3)
End If
Next
End With
Sheets("database").[e2:h2].Resize(UBound(b, 1)).Value = b
End Sub
Bookmarks