Find function for strings in cells

Question

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")
'SrtRng.Sort key1:=Acell, order1:=xlAscending, Header:=xlYes
'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(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:
Sheet1.Protect Password:="abc"
Sheet2.Protect Password:="abc"
Sheet3.Protect Password:="abc"
Sheet5.Protect Password:="abc"
Sheet6.Protect Password:="abc"
Sheet7.Protect Password:="abc"
Sheet8.Protect Password:="abc"
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, Commented Apr 5, 2015 at 7:18

Snowbody · Accepted Answer · 2015-03-30 13:14:36Z

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

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
  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:
  Sheet1.Protect Password:="abc"
  Sheet2.Protect Password:="abc"
  Sheet3.Protect Password:="abc"
  Sheet5.Protect Password:="abc"
  Sheet6.Protect Password:="abc"
  Sheet7.Protect Password:="abc"
  Sheet8.Protect Password:="abc"
  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, Commented Mar 30, 2015 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, Commented Mar 30, 2015 at 5:02
Do you mean as a whole new question? Could I post it as an answer on this thread? — Samatar, Commented Mar 30, 2015 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, Commented Mar 30, 2015 at 5:09

Mathieu Guindon · Accepted Answer · 2015-03-30 13:52:04Z

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)

        .DisplayAlerts = Not wait
        .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

Should actually read like this:

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, Commented Mar 30, 2015 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, Commented Mar 30, 2015 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, Commented Mar 30, 2015 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, Commented Mar 31, 2015 at 1:57

Comintern · Accepted Answer · 2015-03-31 04:56:56Z

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

user66882user66882 · Accepted Answer · 2015-04-05 06:52:06Z

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"
            .Interior.Color = RGB(157, 153, 156)  'don't know about this bit
            .NumberFormat = "[Color10]ü;[Color10]ü;[Color3]û;"
         End If
     Next cell

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.

Stack Exchange Network

Find function for strings in cells

4 Answers 4

Your Answer

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.

Hot Network Questions

Find function for strings in cells

4 Answers 4

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged performancevbaexcel or ask your own question.

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.