Macro to highlight certain cells highlighting too much

[czeknere]

Working on a small macro that will allow a user to find a given list of words throughout an excel document. If the word is found the whole row is highlighted in red. It works, but for some reason it highlights a bunch of empty cells after the cells containing information. Code is below:




Sub DeleteExclusions()

Dim SearchString
Dim i As Long, j As Long, calc As Long

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

SearchString = Array("Term1", "Term2", "Term3", "Term4")

With ActiveSheet
.AutoFilterMode = False
For j = 3 To 4 '3 = Col C and 4 = Col D
For i = LBound(SearchString) To UBound(SearchString)
.Cells(1).AutoFilter Field:=j, Criteria1:="=*" & SearchString(i) & "*"
If .AutoFilter.Range.Rows.Count > 1 Then
.UsedRange.Columns(1).Offset(1).SpecialCells(12).EntireRow.Interior.ColorIn dex = 3
End If
Next i
.AutoFilterMode = False
Next j
End With



With Application
.EnableEvents = False
.Calculation = calc
End With


End Sub




I had tried to add a section after the main part that would then go back and find any blank cells and turn them back to white. I know it's not ideal, but it was a work around. However, when my coworker runs the macro she gets a Runtime 1004 - "autofilter method of range class failed" so I'd like to avoid going this route if possible.

Hopefully this is enough information. Thanks in advance for the help!

[Paul_Hossler]

Basically your, but I changed some variable names so I could keep then straight

I added the .Areas logic because I didn't like highlighting the titles

There was no example attached workbook (hint, hint) so you might have to adjust this




Option Explicit

Sub DeleteExclusions()

Dim SearchString As Variant
Dim strnum As Long, colnum As Long, calcstatus As Long, k As Long
Dim R As Range

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
calcstatus = .Calculation
.Calculation = xlCalculationManual
End With

SearchString = Array("Term1", "Term2", "Term3", "Term4")

With ActiveSheet

For colnum = 3 To 4 '3 = Col C and 4 = Col D

For strnum = LBound(SearchString) To UBound(SearchString)

.AutoFilterMode = False

.Rows(1).AutoFilter Field:=colnum, Criteria1:="=*" & SearchString(strnum) & "*"
Set R = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)

If R.Areas.Count = 1 Then
If R.Areas(1).Rows.Count > 1 Then
R.Cells(2, 1).Resize(R.Rows.Count - 1, R.Columns.Count).Interior.ColorIndex = 3
End If
Else
If R.Areas(1).Rows.Count > 1 Then
R.Areas(1).Cells(2, 1).Resize(R.Areas(1).Rows.Count - 1, R.Areas(1).Columns.Count).Interior.ColorIndex = 3
End If

For k = 2 To R.Areas.Count
R.Areas(k).Interior.ColorIndex = 3
Next k
End If
Next strnum

.AutoFilterMode = False

Next colnum
End With


With Application
.EnableEvents = False
.Calculation = calcstatus
End With


End Sub

[czeknere]

Thanks so much! I'll give this a shot when I'm back in the office tomorrow and report back. I couldn't really post a workbook because it's a company spreadsheet with proprietary info in it. If necessary I can submit a redacted one, but I'll give this a shot first and see what happens. Thanks again!

[Paul_Hossler]

Like I said, you'll most likely have to adapt my suggestions

[czeknere]

Actually, it worked right out of the box. I just added my search terms to the array and it worked like a charm. Thank you again!