```
Sub DeleteRows()
Application.ScreenUpdating = False
Dim srcWB As Workbook, srcWS As Worksheet, desWS As Worksheet, LastRow As Long, x As Long
Set desWS = ThisWorkbook.Sheets("Open Vendors Jobs")
LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim Rng As Range, RngList As Object
Set RngList = CreateObject("Scripting.Dictionary")
Set srcWB = Workbooks.Open("C:\Users\edward.selkov\Working\ExcludedWo's.xlsm")
Set srcWS = Sheets("EXCWOS")
For Each Rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
If Not RngList.Exists(Rng.Value) Then
RngList.Add Rng.Value, Nothing
End If
Next Rng
For x = LastRow To 2 Step -1
If RngList.Exists(desWS.Cells(x, 1).Value) Then
desWS.Rows(x).EntireRow.Delete
End If
Next x
RngList.RemoveAll
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each Rng In desw.Range("A2", desw.Range("A" & desw.Rows.Count).End(xlUp))
If Not RngList.Exists(Rng.Value) Then
RngList.Add Rng.Value, Nothing
End If
Next Rng
For x = LastRow To 2 Step -1
If Not RngList.Exists(srcWS.Cells(x, 1).Value) Then
srcWS.Rows(x).EntireRow.Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
```