Find function for strings in cells

In column A, I have many strings ~ 32000 cells each containing unique string values. I then have columns C to as many as 30/40 columns which all contain approximately 400 rows of text.

• Check column (j) for any text not present in column A

• If true then add new string to column A

• Run comparison of Column A against column (j)

• If a match is found then place a checkmark in the corresponding column (j) for the row where the string is found

However the problem is that this can take up to 7 or 8 minutes for 10 columns of data. This is far too long and surely there is a faster way to run this comparison?

```
Sub AddSignals()

Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, id As Long, idL As Long, var As Range, var2 As Range, j As Long, ws1 As Worksheet, ws2 As Worksheet, jL As Long, rng5 As Range, jFn As Long, iLs As Long, iLss As Range, rng1s As Range, rng2s As Range
Dim rng3 As Range, rng4 As Range, lCols As Long, lRows As Long, SrtRng As Range, Acell As Range, iLs2 As Long, iLss2 As Range, SrtRngF As Range, AcellF As Range
Dim Clnup As Range, Clncol As Long, ClnRow As Long, trimrng As Range, trimrng1 As Range, emptyrange As Range, EmptyCol As Long

On Error GoTo ErrHandler

Set ws1 = Sheet7
Set ws2 = Sheet2

'Look for new signals and add to sigal list
jL = ws1.Cells(7, Columns.Count).End(xlToLeft).Column

For j = 3 To jL
'Set range limits
jF = ws2.Cells(7, Columns.Count).End(xlToLeft).Column
jFn = jF + 1
ws2.Cells(7, jFn).Value = ws1.Cells(7, j).Value

idL = ws1.Cells(Rows.Count, j).End(xlUp).Row

For id = 8 To idL
'iLs = ws1.Cells(Rows.Count, 1).End(xlUp).Row
iLs2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'Set iLss = ws1.Cells(iLs + 1, 1)
Set iLss2 = ws2.Cells(iLs2 + 1, 1)

Set rng1s = ws1.Cells(id, j)
If Not IsEmpty(rng1s) Then
Set rng2s = ws2.Range(ws2.Cells(7, 1), ws2.Cells(ws2.Cells(Rows.Count, 1).End(xlUp).Row, 1))
Set var2 = rng2s.Find(rng1s.Value, LookIn:=xlValues, Look

First a few stylistic issues.

• Your indentation isn't consistent. It's best to pick an indentation amount and stick with it.

• Your code has repeated sections. Those should be extracted to separate functions.

• Your code has magic numbers. Those should be extracted to named constants.

• Your sub is hardcoded to Sheet2 and Sheet7. What if in the future you need to work on different sheets?

• Correcting misspellings ("sigal") is always a good idea.

• You have some dead code, such as an Exit Sub immediately before End Sub and an empty Else block, and the calls to iLss.SpecialCells (xlCellTypeConstants) which throw away the return value and have no effect. The function is already overlong; eliminating lines will make it more readable.

• It's not at all clear why some lines are commented out. Are you intending to put them back in? If so put them in If blocks or #If blocks, which clearly show the conditions where the code should be used. If not, take them out.

And trying to answer your question:

• VBA's Find command makes no assumptions about the data it searches. Since the lists are sorted, you should be exploiting that, by using a binary search.

And a question of my own:

• What is lCols0 = ws1.Cells(7, Columns.Count).Column supposed to accomplish? It always sets lCols0 = Columns.Count. Did you mean to have a .End() call in there?

`Sub AddCheckmark(ByVal cell as Range)
cell.Font.Name = "Wingdings"
cell.Value = ChrW(&HFB)
cell.Interior.Color = RGB(157, 153, 156)
End Sub

Sub AddFailMark(ByVal rng5 as Range)
rng5.Font.Name = "Wingdings"
rng5.Value = ChrW(&HFC)
rng5.Interior.Color = RGB(6, 232, 49)
End Sub

Function BinarySearch(r as Range, v as string) As Boolean
dim minIndex As Long, maxIndex As Long, midIndex As Long
minIndex = 1
maxIndex = r.Count + 1
While minIndex r(midIndex) Then
maxIndex = midIndex
Else
minIndex = midIndex+1
End If
Wend
BinarySearch = False
End Function

Sub AddSignals()

Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, id As Long, idL As Long, var As Range, var2 As Range, j As Long, ws1 As Worksheet, ws2 As Worksheet, jL As Long, rng5 As Range, jFn As Long, iLs As Long, iLss As Range, rng1s As Range, rng2s As Range
Dim rng3 As Range, rng4 As Range, lCols As Long, lRows As Long, SrtRng As Range, Acell As Range, iLs2 As Long, iLss2 As Range, SrtRngF As Range, AcellF As Range
Dim Clnup As Range, Clncol As Long, ClnRow As Long, trimrng As Range, trimrng1 As Range, emptyrange As Range, EmptyCol As Long

On Error GoTo ErrHandler

Set ws1 = Sheet7
Set ws2 = Sheet2

'Look for new signals and add to signal list
jL = ws1.Cells(7, Columns.Count).End(xlToLeft).Column

For j = 3 To jL
'Set range limits
jF = ws2.Cells(7, Columns.Count).End(xlToLeft).Column
jFn = jF + 1
ws2.Cells(7, jFn).Value = ws1.Cells(7, j).Value

idL = ws1.Cells(Rows.Count, j).End(xlUp).Row

For id = 8 To idL
iLs2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Set iLss2 = ws2.Cells(iLs2 + 1, 1)

Set rng1s = ws1.Cells(id, j)
If Not IsEmpty(rng1s) Then
Set rng2s = ws2.Range(ws2.Cells(7, 1), ws2.Cells(ws2.Cells(Rows.Count, 1).End(xlUp).Row, 1))
Set var2 = rng2s.Find(rng1s.Value, LookIn:=xlValues, LookAt:=xlWhole)
If var2 Is Nothing Then
bln = True
If bln = True Then
iLss2.Value = rng1s.Value
'remove any spaces from cells
iLss2.Value = WorksheetFunction.Trim(iLss2.Value)
Set emptyrange = ws2.Range(ws2.Cells(iLss2.Row, 2), ws2.Cells(iLss2.Row, jF))
For Each cell In emptyrange
If IsEmpty(cell) Then
AddCheckMark cell
End If
Next cell
Else
End If

End If
End If
Next id

'Sort signal list in alphabetical order (in measurement database sheet)
SrtRowF = ws2.Cells(Rows.Count, 1).End(xlUp).Row
SrtColF = ws2.Cells(7, Columns.Count).End(xlToLeft).Column
Set SrtRngF = ws2.Range(ws2.Cells(7, 1), ws2.Cells(SrtRowF, SrtColF))
Set AcellF = ws2.Range("A7")
SrtRngF.Sort key1:=AcellF, order1:=xlAscending, Header:=xlYes

iL = ws2.Range("A" & Rows.Count).End(xlUp).Row

ws2.Columns(jFn).AutoFit

'Run comparison of each measurement file one by one
Set rng2 = ws1.Range(ws1.Cells(7, j), ws1.Cells(Rows.Count, j).End(xlUp))
For i = 8 To iL
Set rng1 = ws2.Cells(i, 1)
found = BinarySearch(rng2,rng1.Value)
Set rng5 = ws2.Cells(i, jFn)
If Not found Then
AddFailMark rng5
Else
AddCheckMark rng5
End If
Next i
Next j

'Cleanup final sheet
ClnRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Clncol = ws2.Cells(7, Columns.Count).End(xlToLeft).Column

Set Clnup = ws2.Range(ws2.Cells(7, 2), ws2.Cells(ClnRow, Clncol))
Clnup.VerticalAlignment = xlCenter
Clnup.HorizontalAlignment = xlCenter

'Clear draft sheet
lRows

StackExchange Code Review Q#85367, answer score: 4