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

 

[Legacy 143009]

At this point I can't see a beneficial use of dictionaries. maybe someone does.
My code considers your partial part list is in column G. You can change this address to wherever you want. The following code should be fast enough:

Sub test()
  Dim myArray As Variant, parts As Variant, myRange As Range, part As Variant
  With Application
  myArray = .Transpose(Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row))
  parts = .Transpose(Range("G1:G" & Cells(Rows.Count, "G").End(xlUp).Row))
  Set myRange = Range("XFD1048576") 'Just to set something to myRange
  For Each part In parts
    If Not IsError(.Match("*" & part & "*", myArray, 0)) Then
      Set myRange = .Union(myRange, Range("D" & .Match("*" & part & "*", myArray, 0)))
    End If
  Next
  
  .ScreenUpdating = False
  myRange.Interior.ColorIndex = 6
  Range("XFD1048576").Interior.ColorIndex = xlNone
  .ScreenUpdating = True
  End With
End Sub

 

[Muhammad_Usman]

1235.xlsm
	A	B	C	D	E	F	G	H	I
1	Superstructure Name
2	Level	Pos.	Asm. No.	Asm. Name	Amount				List For Highlightes
3	1.........	1		Fan	1				Housing
4	.2........	1		Blades	3				Base
5	.2........	2		Motor	1				Grille
6	.2........	3		Housing	1
7	.2........	4		Oscillator	1
8	.2........	5		Screws	15
9	.2........	6		Base	1
10	.2........	7		Switch	1
11	.2........	8		Power Chord	1
12	.2........	9		Grille	1
Sheet13

Sub HighlightMatchingValues()
    Dim ws As Worksheet
    Dim lastRowD As Long, lastRowF As Long
    Dim cellD As Range, cellF As Range

    ' Set the worksheet to work with
    Set ws = ThisWorkbook.Sheets("Sheet13") ' Replace "Sheet13" with your sheet name

    ' Clear previous highlights (remove background color) in column D
    ws.Range("D1:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row).Interior.ColorIndex = xlNone

    ' Find the last row in columns D and I
    lastRowD = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    lastRowF = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row

    ' Loop through each cell in column D
    For Each cellD In ws.Range("D3:D" & lastRowD)
        ' Loop through each cell in column F
        For Each cellF In ws.Range("I3:I" & lastRowF)
            ' Check if the value in column D exists in column F
            If cellD.Value = cellF.Value Then
                ' Highlight the cell in column D
                cellD.Interior.ColorIndex = 6 ' Change the color index as needed
                Exit For ' Exit the loop after the first match
            End If
        Next cellF
    Next cellD
End Sub

Change code according to your data range and sheet name

 

[Georgiboy]

How about using conditional formatting, or is that not an option for you?

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

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
D3:D12	Expression	=ISNUMBER(SEARCH("Button Panel",D3))	text	NO
D3:D12	Expression	=ISNUMBER(SEARCH("Switch",D3))	text	NO
D3:D12	Expression	=ISNUMBER(SEARCH("Oscillator",D3))	text	NO
D3:D12	Expression	=ISNUMBER(SEARCH("Motor",D3))	text	NO

 

[Norie]

How about using conditional formatting, set via code?

Option Explicit

Sub FormatThings()
Dim rng As Range
Dim arrValues As Variant
Dim idx As Long

    arrValues = Array("Switch", "Motor", "Oscillator")
    Set rng = Range("D3", Range("D" & Rows.Count).End(xlUp))

    With rng.FormatConditions
        .Delete
        For idx = LBound(arrValues) To UBound(arrValues)
            .Add Type:=xlTextString, String:=arrValues(idx), TextOperator:=xlContains

            With rng.FormatConditions(idx + 1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 65535
                .TintAndShade = 0
            End With
        Next idx
      
    End With

End Sub

 

[Peter_SSs]

Another option to test for speed.

Sub Check_Parts()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long

  Set RX = CreateObject("VBscript.RegExp")
  RX.Pattern = "Motor|Oscillator|Switch|Button Panel" '<- add more if required
  With Range("D3", 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
      Application.ScreenUpdating = False
      .Value = b
      .SpecialCells(xlConstants).Interior.ColorIndex = 6
      .Value = a
      Application.ScreenUpdating = True
    End If
  End With
End Sub

@Georgiboy
To emulate the OP's case-sensitive code you would need to use FIND instead of SEARCH.
Also, in CF there would be no need for the ISNUMBER check since any error result will mean the CF test fails and the cell would not be coloured anyway.

 

[kevin9999]

Also combination of VBA and conditional formatting, again using a named range on your sheet called "parts" for easy adding of new items. Tested at 100K rows at 0.02 secs.

Option Explicit
Sub Highlight_If_Found()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    Set ws = Worksheets("Sheet1")       '<-- *** Change sheet name as required ***
    
    With ws.Range("D3", ws.Cells(Rows.Count, "D").End(xlUp))
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, _
        Formula1:="=NOT(ISERROR(MATCH(""*""&D3&""*"",parts,0)))"
        .FormatConditions(1).Interior.Color = vbYellow
    End With
    Application.ScreenUpdating = True
End Sub

Before:

test.xlsm
	A	B	C	D	E	F	G	H
1	Superstructure Name
2	Level	Pos.	Asm. No.	Asm. Name	Amount			Range named "parts"
3	1.........	1		Fan	1			Motor
4	.2........	1		Blades	3			Oscillator
5	.2........	2		Motor	1			Switch
6	.2........	3		Housing	1			Button Panel
7	.2........	4		Oscillator	1
8	.2........	5		Screws	15
9	.2........	6		Base	1
10	.2........	7		Switch	1
11	.2........	8		Power Chord	1
12	.2........	9		Grille	1
13	1.........	1		Fan	1
14	.2........	1		Blades	3
15	.2........	2		Motor	1
16	.2........	3		Housing	1
17	.2........	4		Oscillator	1
18	.2........	5		Screws	15
19	.2........	6		Base	1
20	.2........	7		Switch	1
21	.2........	8		Power Chord	1
22	.2........	9		Grille	1
Sheet1

After

test.xlsm
	A	B	C	D	E	F	G	H
1	Superstructure Name
2	Level	Pos.	Asm. No.	Asm. Name	Amount			Range named "parts"
3	1.........	1		Fan	1			Motor
4	.2........	1		Blades	3			Oscillator
5	.2........	2		Motor	1			Switch
6	.2........	3		Housing	1			Button Panel
7	.2........	4		Oscillator	1
8	.2........	5		Screws	15
9	.2........	6		Base	1
10	.2........	7		Switch	1
11	.2........	8		Power Chord	1
12	.2........	9		Grille	1
13	1.........	1		Fan	1
14	.2........	1		Blades	3
15	.2........	2		Motor	1
16	.2........	3		Housing	1
17	.2........	4		Oscillator	1
18	.2........	5		Screws	15
19	.2........	6		Base	1
20	.2........	7		Switch	1
21	.2........	8		Power Chord	1
22	.2........	9		Grille	1
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
D3:D100002	Expression	=NOT(ISERROR(MATCH("*"&D3&"*",parts,0)))	text	YES

 

[Georgiboy]

@Georgiboy
To emulate the OP's case-sensitive code you would need to use FIND instead of SEARCH.
Also, in CF there would be no need for the ISNUMBER check since any error result will mean the CF test fails and the cell would not be coloured anyway.

Yes sorry, posted first thing in the morning before my first black coffee.

Below for completeness:

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

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
D3:D12	Expression	=FIND("Button Panel",D3)	text	NO
D3:D12	Expression	=FIND("Switch",D3)	text	NO
D3:D12	Expression	=FIND("Oscillator",D3)	text	NO
D3:D12	Expression	=FIND("Motor",D3)	text	NO

 

[SY24]

Thank you @Georgiboy and @Norie for your solutions. But I'm afraid I cannot use conditional formatting in my case. There are other operations being applied to our parts-lists. But I will definitely give your ideas a try!

Thank you @Muhammad_Usman and @Flashbond for your solutions and @kevin9999 for the combination with conditional formatting. Again, I'm not sure if that would fit into our process, but I will give it a try. Tho could I have this extra range you used on a different Excel file? And if so, how would I achieve that through code? That way my colleagues would be able to add entries by themselves which would come in handy.

Thank you @Peter_SSs for your solution. I will definitely give this a try. In our case we have around 100 options, and I fear the code would become harder to read the more options I add. Do you have an idea on how I could make this easier to read? And would this work with wildcards as well?

 

[Peter_SSs]

And would this work with wildcards as well?

It already acts as if wildcards are included since that is what your original post 1 code did. Here is the results of my code with some different data.
Note the comments earlier in the thread about case-sensitivity though and that "oscillator" in cell D14 is not highlighted since your original 'working code' also would not highlight that cell. Is that what you want?

SY24_1.xlsm
	D
2	Asm. Name
3	Fan
4	Blades
5	Motor
6	Housing
7	Oscillator
8	Screws
9	Base
10	Switch Board Meter
11	Power Chord
12	Grille
13	Electric Motor
14	oscillator
15	Blue Switches
Sheet1 (5)

I fear the code would become harder to read the more options I add. Do you have an idea on how I could make this easier to read?

There would be at least two options.

1. Write the Pattern line in a multi-line format like this

 RX.Pattern = "Text1|Text2|Text3|Text4|Text5|Text6|Text7|Text8|Text9|Text10|Text11|" & _
                "Text12|Text13|Text14|Text15|Text16|Text17|Text18|Text19|Text20|" & _
                "Text21|Text22|Text23|Text24|Text25|Text26|Text27|Text28|Text29|Text30|" & _
                "Text31|Text32|Text33|Text34|Text35"

2. Write the texts of interest in a column somewhere (as suggested earlier in the thread) ..

SY24_1.xlsm
	J
1
2	Text1
3	Text2
4	Text3
5	Text4
6	Text5
7	Text6
8	Text7
9	Text8
10	Text9
11	Text10
12	Text11
13	Text12
14	Text13
15	Text14
16	Text15
17	Text16
18	Text17
19	Text18
20	Text19
21	Text20
22	Text21
23	Text22
24	Text23
25	Text24
26	Text25
27	Text26
28	Text27
29	Text28
30	Text29
31	Text30
32	Text31
33	Text32
34	Text33
35	Text34
36	Text35
Sheet1 (5)

.. and write the Pattern line like this

RX.Pattern = Join(Application.Transpose(Range("J2", Range("J" & Rows.Count).End(xlUp)).Value), "|")