Option Explicit
Sub FindeUndFärbe()
Dim sArr(2) As String
Dim xAreas As Long, byt As Byte, lCalc As Long, lEvents As Long
Dim rng As Excel.Range
On Error GoTo FinishErr
With Application
lCalc = .Calculation
lEvents = .EnableEvents
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
sArr(0) = "292*"
sArr(1) = "293*"
sArr(2) = "294*"
Set rng = ActiveSheet.Range("A1").CurrentRegion
For byt = LBound(sArr) To UBound(sArr)
rng.AutoFilter Field:=1, Criteria1:=Array("=", sArr(byt)), Operator:=xlFilterValues
xAreas = rng.SpecialCells(xlCellTypeVisible).Areas.Count
While xAreas > 1
With rng.SpecialCells(xlCellTypeVisible).Areas(xAreas)
If .Cells(1, 1).Value Like sArr(byt) Then
If .Rows.Count > 1 Then .Resize(.Rows.Count - 1).Offset(1).Interior.Color = RGB(255, 255, 0)
End If
End With
xAreas = xAreas - 1
Wend
Next byt
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
FinishErr:
Select Case Err.Number
Case Is <> 0
MsgBox Err.Number & vbNewLine & Err.Description
End Select
With Application
.Calculation = lCalc
.EnableEvents = lEvents
.ScreenUpdating = True
End With
Set rng = Nothing
Erase sArr()
End Sub