# 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, LookAt:=xlWhole)
If var2 Is Nothing Then
bln = True
If bln = True Then
'rng1s.Interior.Color = RGB(255, 255, 0)
'iLss.Value = rng1s.Value
iLss2.Value = rng1s.Value
' iLss.SpecialCells (xlCellTypeConstants)
'remove any spaces from cells
' iLss.Value = WorksheetFunction.Trim(iLss.Value)
iLss2.SpecialCells (xlCellTypeConstants)
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
cell.Font.Name = "Wingdings"
cell.Value = ChrW(&HFB)
cell.Interior.Color = RGB(157, 153, 156)
End If
Next cell
Else
End If

End If
End If
Next id

'Removes any spaces from cells
'Set trimrng1 = ws2.Range(ws2.Cells(8, 1), ws2.Cells(iLs, 1))
'For Each cell In trimrng1.SpecialCells(xlCellTypeConstants)
'cell.Value = WorksheetFunction.Trim(cell.Value)
'Next cell

'Sort signal list in alphabetical order (in draft sheet)
'SrtRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
'SrtCol = ws1.Cells(7, Columns.Count).End(xlToLeft).Column
'Set SrtRng = ws1.Range(ws1.Cells(7, 1), ws1.Cells(SrtRow, SrtCol))
'Set Acell = ws1.Range("A7")
'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")

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(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
For i = 8 To iL
Set rng1 = ws2.Range("A" & i)
Set rng5 = ws2.Cells(i, jFn)
Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not var Is Nothing Then
'rng1.Interior.Color = RGB(255, 255, 0)
'rng2.Interior.Color = RGB(255, 100, 100)
rng5.Font.Name = "Wingdings"
rng5.Value = ChrW(&HFC)
rng5.Interior.Color = RGB(6, 232, 49)
Else
rng5.Font.Name = "Wingdings"
rng5.Value = ChrW(&HFB)
rng5.Interior.Color = RGB(157, 153, 156)

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
lRows0 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lCols0 = ws1.Cells(7, Columns.Count).Column
Set rng = ws1.Range(ws1.Cells(7, 2), ws1.Cells(lRows0, lCols0))
rng.ClearContents
ws2.Rows(7).Font.Name = "Calibri"

Call Meas_Info

ErrHandler:
Sheet5.Visible = xlSheetVeryHidden
Sheet6.Visible = xlSheetVeryHidden
Sheet7.Visible = xlSheetVeryHidden
Sheet8.Visible = xlSheetVeryHidden

If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Exit Sub

End Sub

• What is bln = True: If bln = True Then intended to do and why does it come with an empty Else clause? – user66882 Apr 5 '15 at 7:18

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.

• 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

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 < maxIndex
midIndex = (minIndex + maxIndex)/2
if (v = r(midIndex)) Then
BinarySearch = True
Exit Function
ElseIf v > r(midIndex) Then
maxIndex = midIndex
Else
minIndex = midIndex+1
End If
Wend
BinarySearch = False
End Function

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
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")

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)
Else
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
lRows0 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lCols0 = ws1.Cells(7, Columns.Count).Column
ws1.Range(ws1.Cells(7, 2), ws1.Cells(lRows0, lCols0)).ClearContents

ws2.Rows(7).Font.Name = "Calibri"

Call Meas_Info

ErrHandler:
Sheet5.Visible = xlSheetVeryHidden
Sheet6.Visible = xlSheetVeryHidden
Sheet7.Visible = xlSheetVeryHidden
Sheet8.Visible = xlSheetVeryHidden

If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Exit Sub

End Sub

• Appreciate the detailed explanation. I will improve on my presentation or writing style to make it more clear in the future. To answer some of the points : I have hardcoded the sheets as I do not anticipate needing to use different sheets in the future, also is there a way to code sheets without using sheet names? how can I use more flexible method I do not understand that? The commented out lines need to be removed and I have now removed them from the question. To answer your question I ddi forget to put an end.(xltoleft)which I have since added. Binary search? Can you explain a bit further? – Samatar Mar 30 '15 at 4:50
• Please don't edit the original code. It's codereview.SE's policy that the code should stay as it was originally submitted (please put it back the way it was). If you want a review of modified code, post it as a new question. – Snowbody Mar 30 '15 at 5:02
• Sure thing (sorry!) – Samatar Mar 30 '15 at 5:03
• Do you mean as a whole new question? Could I post it as an answer on this thread? – Samatar Mar 30 '15 at 5:05
• Yes, a whole new question. The only reason you'd post it as an answer is if you had improved it as much as possible and didn't want anyone else to review it but wanted to make the improved code available to others who browsed your question. – Snowbody Mar 30 '15 at 5:09

You need a procedure similar to this one:

Private Sub ToggleWaitMode(Optional ByVal wait As Boolean = True)
With Excel.Application

.Calculation = IIf(wait, xlCalculationManual, xlCalculationAutomatic)
.Cursor = IIf(wait, xlWait, xlDefault)
.StatusBar = IIf(wait, "Please wait...", False)

.ScreenUpdating = Not wait

End With

End Sub


Call ToggleWaitMode before you start looping, and then ToggleWaitMode False you all exit paths, i.e. both normal exit and error exit - ideally error exit resumes to normal exit, so this:

ErrHandler:
' <code>
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Exit Sub

End Sub


CleanExit:
'<cleanup-code>
Exit Sub

ErrHandler:
'<error-handling-code>
Resume CleanExit
End Sub


Checking for Err.Number <> 0 in the ErrHandler subroutine indicates that the "happy path" actually enters that subroutine. That's not good coding; your cleanup code doesn't belong with the error-handling code.

But I digress - I meant to say that the biggest bottleneck you have here, is Excel itself. By turning off automatic calculation and screen updating while you're updating the worksheet, you can save lots of useless processing and tremendously improve performance.

I ran Rubberduck 1.21 (my pet project) code inspections, and got this:

Rubberduck Code Inspections - 3/30/2015 7:23:15 AM
28 issues found.
Hint: Variable 'iLs' is never used - VBAProject.Module1, line 3
Hint: Variable 'iLss' is never used - VBAProject.Module1, line 3
Hint: Variable 'rng3' is never used - VBAProject.Module1, line 4
Hint: Variable 'rng4' is never used - VBAProject.Module1, line 4
Hint: Variable 'lCols' is never used - VBAProject.Module1, line 4
Hint: Variable 'lRows' is never used - VBAProject.Module1, line 4
Hint: Variable 'SrtRng' is never used - VBAProject.Module1, line 4
Hint: Variable 'Acell' is never used - VBAProject.Module1, line 4
Hint: Variable 'trimrng' is never used - VBAProject.Module1, line 5
Hint: Variable 'trimrng1' is never used - VBAProject.Module1, line 5
Hint: Variable 'EmptyCol' is never used - VBAProject.Module1, line 5
Warning: Use of obsolete Call statement - VBAProject.Module1, line 124
Error: Variable 'iLs' is never assigned - VBAProject.Module1, line 3
Error: Variable 'iLss' is never assigned - VBAProject.Module1, line 3
Error: Variable 'rng3' is never assigned - VBAProject.Module1, line 4
Error: Variable 'rng4' is never assigned - VBAProject.Module1, line 4
Error: Variable 'lCols' is never assigned - VBAProject.Module1, line 4
Error: Variable 'lRows' is never assigned - VBAProject.Module1, line 4
Error: Variable 'SrtRng' is never assigned - VBAProject.Module1, line 4
Error: Variable 'Acell' is never assigned - VBAProject.Module1, line 4
Error: Variable 'trimrng' is never assigned - VBAProject.Module1, line 5
Error: Variable 'trimrng1' is never assigned - VBAProject.Module1, line 5
Error: Variable 'EmptyCol' is never assigned - VBAProject.Module1, line 5
Warning: Option Explicit is not specified - VBAProject.Module1, line 1
Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 5
Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 4
Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 3
Suggestion: Member 'AddSignals' is implicitly Public - VBAProject.Module1, line 1


You have dead code in there, declared variables only used in commented-out code, if at all; it's hard to tell which ones it is, because you're not declaring them as close as possible to their usage - instead you cram as many declarations as you can "reasonably" fit on a single line. You have variables that you assign but that aren't used anywhere: this code needs a major cleanup!

Most of the identifiers you're using are meaningless and confusing, and the apparent need to number some of them makes me think you may have repeated logic to extract into separate methods, although I haven't looked at the code in details.

• You are correct my code is confusing and this is extremely useful for me to improve my code Thanks!. I need to write it out more clearly. Instances when some of them are used do exist for e.g. if a string is found that is not in column A then emptycol and trimrng are used. – Samatar Mar 30 '15 at 6:37
• Secondly just to understand you a bit better, are you saying that the main issue with performance is not the fact that I am using find function but more to do with the screen updating issue? Also I am not so good with coding as you can probably tell a beginner what exactly does toggling do that I can not achieve by just starting with Application.ScreenUpdating =False ? – Samatar Mar 30 '15 at 6:40
• Abstraction. The difference between a cryptic script and maintainable program. You need to understand that there is no difference as far as running the code is concerned - you could be writing it in assembly, wouldn't make a difference. But abstractions make code human-readable and therefore easier to work with. Functions/procedures should do as little as possible; you have a "god method" here, that knows everything. Also, how do you know the Find is your bottleneck? My experience has been that the biggest bottleneck is writing to cells in a loop. – Mathieu Guindon Mar 30 '15 at 12:23
• I have checked which areas of the script take the longest and area during the comparison of the text takes the longest. Naturally it will as I am running many comparisons, I just wanted to see if there is a faster way of comparing it. When you say loops is there a way then where I can take range1 as all cells with data and range 2 as all cells with data and just compare them rather than looping through each cell in range 2 for e.g. this might make it faster however I have no idea on how this would look, also I always need to remember where in range1 the match was found? – Samatar Mar 31 '15 at 1:57

Style comments were covered by other posters, although I'll add a couple more. First, you have some conditionals that don't do anything. For example on this one...

bln = True
If bln = True Then
'...
Else
End If


...you can get rid of the Else clause. In fact since you set bln to True immediately before checking to see if it's True, you can get rid of the If also. On this one...

If Not Var Is Nothing Then
rng5.Font.Name = "Wingdings"
'...
Else
rng5.Font.Name = "Wingdings"
'...
End If


...you set the font to the same value regardless of whether the condition is true or false. There may be others that I missed.

I would also try to use consistent syntax. For example...

Set rng1 = ws2.Range("A" & i)
Set rng5 = ws2.Cells(i, jFn)


... is easier to read if you use the same method to resolve each Range:

Set rng1 = ws2.Cells(i, 1)
Set rng5 = ws2.Cells(i, jFn)


I'm guessing without further forensic analysis that your code is running slow because this structure...

For j = 3 To jL
'...
For ID = 8 To idL
'...
Next ID

For i = 8 To iL
'...
Next i
Next j


...appears loop over the same set of cells repeatedly when their values aren't changing. I don't recommend this often, but you might be best served by a completely different strategy. If all of the values are unique, there isn't any reason to update column A until you are completely finished (or add your check-marks for that matter). This is the part that doesn't make much sense to me:

• 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

Unless you are adding values to column (j), why are you comparing in both directions? If a value is duplicated between the two columns, it obviously is going to be in A after you add it in (j)...

I'd try something like this (pseudo-code):

Load all values from column A into a Dictionary object as keys with the value as false.
For each column (j) you need to check
For each cell in the column
If the column A Dictionary contains the string in the cell
Replace it with a check mark
Add it to the Dictionary and set the value to to true.
End If
Next cell
Next Column

For each key in the column A Dictionary
If the value is true
Add it to the end of column A.
End If
Next Key


While I'm trying to make sense of this, I though I would share something I use to provide checkmarks and crosses in reports destined to be viewed by human beans.

     If CBool(app.CountBlank(emptyrange)) Then
With emptyrange.SpecialCells(xlCellTypeBlanks)
.Value = 0
.Font.Name = "Wingdings"

A 1 in a cell will show a green checkmark; a 0 will show a red ×. An added benefit is the ability to use the raw underlying value in CBool(.cell.value2) as True or False.