Sub Delete_EEE()
Dim Wrds As Variant, Gwrds As Variant, i As Long, Fnd As Range, fAdr As String
Gwrds = Array("jan", "m123", "06014", "06015", "06016", "t49", "m39", "cwr", "64002169", "rnc", "d55", "rer", "rlr", "rwr", "M55", "5962")
Wrds = Array("ohm", "resistor", "semiconductor", "MCKT", "MICKT", "microcircuit", "inductor", "xfmr", "eeprom", "oscillator")
Application.ScreenUpdating = False
For i = LBound(Gwrds) To UBound(Gwrds)
Set Fnd = Range("G:G").Find(Gwrds(i), , , xlPart, , , False)
If Not Fnd Is Nothing Then
fAdr = Fnd.Address
Fnd.Value = "#N/A"
Do
Set Fnd = Range("G:G").FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
If Fnd.Address = fAdr Then Exit Do
Fnd.Value = "#N/A"
Loop
End If
Next i
On Error Resume Next
Range("G:G").SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
On Error GoTo 0
For i = LBound(Wrds) To UBound(Wrds)
Set Fnd = Range("E:E").Find(Wrds(i), , , xlPart, , , False)
If Not Fnd Is Nothing Then
fAdr = Fnd.Address
Fnd.Value = "#N/A"
Do
Set Fnd = Range("E:E").FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
If Fnd.Address = fAdr Then Exit Do
Fnd.Value = "#N/A"
Loop
End If
Next i
On Error Resume Next
Range("E:E").SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
On Error GoTo 0
For i = LBound(Wrds) To UBound(Wrds)
Set Fnd = Range("I:I").Find(Wrds(i), , , xlPart, , , False)
If Not Fnd Is Nothing Then
fAdr = Fnd.Address
Fnd.Value = "#N/A"
Do
Set Fnd = Range("I:I").FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
If Fnd.Address = fAdr Then Exit Do
Fnd.Value = "#N/A"
Loop
End If
Next i
On Error Resume Next
Range("I:I").SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub