Optimize "For Each" routine to fill cells

[SY24]

Greetings,

we use semi-huge parts lists in our company and I'd like to highlight certain parts in yellow. While I do have working VBA code, it operates kinda slowly the bigger our files get (between 200 to 500 rows).

Here's an example:

Assembly.xlsx
	A	B	C	D	E
1	Superstructure Name
2	Level	Pos.	Asm. No.	Asm. Name	Amount
3	1.........	1		Fan	1,000
4	.2........	1		Blades	3,000
5	.2........	2		Motor	1,000
6	.2........	3		Housing	1,000
7	.2........	4		Oscillator	1,000
8	.2........	5		Screws	15,000
9	.2........	6		Base	1,000
10	.2........	7		Switch	1,000
11	.2........	8		Power Chord	1,000
12	.2........	9		Grille	1,000
Sheet1

Dim rCell As Range

    For Each rCell In Range("D:D")
        If rCell.Value Like "*Motor*" Then
            rCell.Interior.ColorIndex = 6
        ElseIf rCell.Value Like "*Oscillator*" Then
            rCell.Interior.ColorIndex = 6
        ElseIf rCell.Value Like "*Switch*" Then
            rCell.Interior.ColorIndex = 6
        ElseIf rCell.Value Like "*Button Panel*" Then
            rCell.Interior.ColorIndex = 6

        End If
    Next

Assembly.xlsx
	A	B	C	D	E
1	Superstructure Name
2	Level	Pos.	Asm. No.	Asm. Name	Amount
3	1.........	1		Fan	1,000
4	.2........	1		Blades	3,000
5	.2........	2		Motor	1,000
6	.2........	3		Housing	1,000
7	.2........	4		Oscillator	1,000
8	.2........	5		Screws	15,000
9	.2........	6		Base	1,000
10	.2........	7		Switch	1,000
11	.2........	8		Power Chord	1,000
12	.2........	9		Grille	1,000
Sheet1

Not all options defined in the code get used in every parts list, but that's ok.

I read a lot of articles and forums for optimizing this routine (many saying that For Each is the slowest), but failed to understand how to implement their solutions to my code. So I am lookin for an efficient and faster operating routine that also lets me add new options whenever needed.

Any help in regards to the problem above is greatly appreciated!

SY24

 

[SY24]

After trying multiple solutions, I decided to use the one from @Peter_SSs and modify that by the suggestions from @Flashbond and @Muhammad_Usman, while moving the extra column into an external worksheet:

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.DisplayPageBreaks = False

Dim RX As Object
Dim a As Variant, b As Variant
Dim i As Long, k As Long

Dim wks As Excel.Worksheet
    Set wks = Worksheets("ActiveSheet")

Dim wkboption As Workbook
    Set wkboption = Workbooks.Open("C:\Path\to\external\Workbook.xlsx")
Dim wksoption As Worksheet
    Set wksoption = wkboption.Worksheets("ExternalSheet")

    Set RX = CreateObject("VBscript.RegExp")
    RX.Pattern = Join(Application.Transpose(wksoption.Range("A2", wksoption.Range("A" & Rows.Count).End(xlUp)).Value), "|")
    With wks.Range("D3", wks.Range("D" & Rows.Count).End(xlUp))
        a = .Value
        ReDim b(1 To UBound(a), 1 To 1)
        For i = 1 To UBound(a)
            If RX.test(a(i, 1)) Then
                b(i, 1) = 1
                k = 1
            End If
        Next i
        If k > 0 Then
            .Value = b
            .SpecialCells(xlConstants).Interior.ColorIndex = 6
            .Value = a
        End If
    End With

    wkboption.Close SaveChanges:=False

While opening an external sheet isn't that fast, it still operates faster than my initial For Each routine. Thanks everyone for the input.

 

[Peter_SSs]

While opening an external sheet isn't that fast

Couldn't you put the list in a (possibly hidden) worksheet in the same workbook as the data you are highlighting?

Thanks everyone for the input.

You're welcome. Glad we were able to help. Thanks for the follow-up.