# Loop through column cells and compare value with a Collection

I have a Collection of 166 elements:

Dim MyCollection As New Collection
...


I want to compare them to the value of the cells in a column. If the value of a cell is not in MyCollection, I change the background color to red.

For i = 2 To lastRow
IsValid = False
For Each Unit In MyCollection
If Range("A" & i).value = Unit Then
IsValid = True
End If
Next Unit
If Not IsValid Then
Range("A" & i).Interior.Color = 192
End If
Next i


However, it takes a long time to finish executing when there is a large number of row and I would like to improve this. Maybe by using something else than a Collection and some VBA functions.

For a lot of data dictionaries are faster than collections, and much more convenient as @RubberDuck mentioned. Lookup times are almost instantaneous, IF you do a lot of lookups, but both collections and dictionaries are slow to initialize

In your case though, the lookups are insignificant. The main issue is caused by updating the cell format in every iteration. I converted the range to an array to minimize interaction with the sheet. Here are the results using the same data set:

1. (Rng) - Total rows: 100,001 in  8.851 sec
2. (Arr) - Total rows: 100,001 in  0.398 sec

1. (Rng) - Total rows: 500,001 in 43.578 sec
2. (Arr) - Total rows: 500,001 in  2.023 sec

Invalid cells: 77,780 (out of 100,000)


.

the code

Option Explicit

Public Sub CompareValues()

Const MAX_SZ    As Byte = 240
Const COL_ID    As Byte = 1
Const COL_LTR   As String = "A"
Const FIRST_ROW As Byte = 2

Const SRCH_LST  As String = "%,%O,D,CMS"
Const LST_START As Byte = 0
Const LST_END   As Byte = 3 '165

Dim ws As Worksheet
Dim thisRow As Long
Dim thisItm As Long
Dim invalidSet As Long
Dim tmp As String
Dim lastRow As Long
Dim colArr As Variant
Dim searchItem As Variant
Dim isValid As Boolean
Dim invalidArr() As String

Set ws = ActiveWorkbook.Worksheets("Sheet1")
With ws
lastRow = .Cells(.Rows.Count, COL_ID).End(xlUp).Row
colArr = .Range(.Cells(FIRST_ROW, COL_ID), .Cells(lastRow, COL_ID)).Value2
End With
searchItem = Split(SRCH_LST, ",")
ReDim Preserve invalidArr(lastRow)
invalidSet = 0

For thisRow = 1 To lastRow - FIRST_ROW + 1
isValid = False
For thisItm = LST_START To LST_END  'compare
If colArr(thisRow, COL_ID) = searchItem(thisItm) Then
isValid = True
Exit For
End If
Next
If Not isValid Then     'if not valid build string of addresses (A1,A3,A7,...)
tmp = tmp & COL_LTR & thisRow + FIRST_ROW - 1 & ","
If Len(tmp) > MAX_SZ Then               'if string length > 240, split it
invalidArr(invalidSet) = Left(tmp, Len(tmp) - 1)   'remove last comma
invalidSet = invalidSet + 1
tmp = vbNullString
End If
End If
Next

If Len(tmp) > 0 Or invalidSet > 0 Then      'if there are invalid values
Dim totalSets As Long
totalSets = invalidSet

If Len(tmp) > 0 Then                    'store the last set, if tmp not empty
invalidArr(invalidSet) = Left(tmp, Len(tmp) - 1)
Else
totalSets = totalSets - 1
End If
ReDim Preserve invalidArr(totalSets)    'cleanup (not needed)
With ws
For invalidSet = 0 To totalSets     'change cell colors in sets of ranges
.Range(invalidArr(invalidSet)).Interior.Color = 192
Next
End With
End If

End Sub

• Thanks for your answer, your solution is way faster than mine. But, in the second For loop, the colArr(thisRow, COL_ID) will only work for the A column (COL_ID = 1). The array is a two dimensional array and it should always be 1 for the second argument when retriving a value from the array (colArr(thisRow, 1). – varnaud Aug 24 '15 at 17:17

Scripting.Dictionary may provide a better lookup time depending on how large the data is. source

It will, however, provide a nicer experience and make the code more understandable.

If Not dict.Exists(Range("A" & i).value) Then
Range("A" & i).Interior.Color = 192