VBA Slow and doesn't work with longer sets of data - vba

Question

Thanks for taking the time to look at this. I'm trying to figure out why this macro works with smaller lists of keywords but when we put in larger lists it doesn't work AND goes too slowly.
Program works like this:
Column A is the input: we paste keywords of interest
Column B is output 1: it populates with all the noise words or stop words that aren't of interest from A. (there will be a 2nd sheet where we can create a list of non-interest words like the, is, by, but, etc)
Column C is output 2: it populates with all the special characters from A.
This is what I have...works with smaller not with bigger sets of words. Been stumped for a while.
Option Explicit
Dim KeywordSearch As Range
Dim NoiseWords As Range
Dim cell As Range
Dim NoiseWord As Range
Dim i As Long , j As Long
Dim NWTable As ListObject
Dim NewRow As ListRow
Dim SCTable As ListObject
Sub Highlight()
Dim s As String
Dim offset As Integer
Dim word As String
Worksheets("Keyword Search").Activate
Set KeywordSearch = ActiveSheet.Range("B3", Range("B3").End(xlDown))
Set NWTable = ActiveSheet.ListObjects("Table1")
Set SCTable = ActiveSheet.ListObjects("SC")
Worksheets("Noise Words").Activate
Set NoiseWords = ActiveSheet.Range("B2", Range("B2").End(xlDown))
' clear table
On Error Resume Next
NWTable.DataBodyRange.ClearContents
Dim r As Range
Set r = NWTable.Range.Rows(1).Resize(2)
NWTable.Resize r
SCTable.DataBodyRange.ClearContents
Dim t As Range
Set t = SCTable.Range.Rows(1).Resize(2)
SCTable.Resize t
On Error GoTo 0
For Each cell In KeywordSearch
s = cell.Value
offset = 1
cell.Interior.Color = vbWhite
cell.Characters.Font.Color = vbBlack
Do
'Replace smart quotes
For j = 1 To Len(s)
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(147), """")
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(148), """")
' Find the special characters and add to SpecialCharacters list
If InStr("""!##$%&'+,.:;<=>?^`{|}~*()/", Mid(s, j, 1)) > 0 Then
cell.Characters(j, 1).Font.Color = vbRed
Set NewRow = SCTable.ListRows.Add
NewRow.Range.Cells(1, 1) = Mid(s, j, 1)
' Replace with spaces
Mid(s, j, 1) = " "
End If
Next
' Find the next space
i = InStr(offset, s, " ")
' If no spaces left then go to end
If i = 0 Then
i = Len(s) + 1
End If
' Extract the word
word = LCase(Mid(s, offset, i - offset))
' Capitalize AND OR NOT
If word = "and" Or word = "not" Or word = "or" Then
For j = 1 To Len(word)
cell.Characters(offset + j - 1, 1).Text = UCase(Mid(word, j, 1))
Next
End If
' Special case to capitalize w/
If word = "w/" And i < Len(s) Then
cell.Characters(i - 2, 2).Text = UCase(word)
End If
' Is the word in the NoiseWord list?
For Each NoiseWord In NoiseWords
If NoiseWord.Value = word Then
' Highlight word
cell.Characters(offset, i - offset).Font.Color = 5287936
' Add to NWList
Set NewRow = NWTable.ListRows.Add
NewRow.Range.Cells(1, 1) = word
Exit For
End If
Next
offset = i + 1
Loop Until i > Len(s)
Next
With NWTable.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("Table1[[#All],[Noise Words]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Apply
End With
NWTable.Range.RemoveDuplicates Columns:=1, Header:=xlYes
SCTable.Range.RemoveDuplicates Columns:=1, Header:=xlYes
Worksheets("Keyword Search").Activate
End Sub

Answer 1

Working with the Characters collection is pretty slow, so you may be stuck with some level of poor performance.
However, there are likely some points where you can shave off time.
E.g:
For j = 1 To Len(s)
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(147), """")
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(148), """")
You don't need to use the characters collection at all here: since you just cleared all of the font color, there's no need to use the Characters approach vs. just replacing via .Value
EDIT: it might be worth setting a flag within to loop to track whether any character-level formatting has been applied, so you can avoid any unneccessary use of .Characters and rely instead on .Value
You can remove this from the loop:
cell.Interior.Color = vbWhite
cell.Characters.Font.Color = vbBlack
and replace with
KeywordSearch.Interior.Color = vbWhite
KeywordSearch.Font.Color = vbBlack
before the loop
This
If word = "and" Or word = "not" Or word = "or" Then
For j = 1 To Len(word)
cell.Characters(offset + j - 1, 1).Text = UCase(Mid(word, j, 1))
Next
End If
could be faster as:
If word = "and" Or word = "not" Or word = "or" Then
cell.Characters(offset, len(word)).Text = UCase(word)
End If

Answer 2

To speed up calculation where you modify values in spreadsheet you need first to disable screen updates and reenable once you finish processing:
Disabling updates:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Reenabling updates:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Answer 3

The problem is definitely with your use of the Characters collection. If you want to colour the different words found, fine, but do it after you manipulate all the string values.
Side Note: The repeated use of ActiveSheet scares me. Please set this to a variable at the start of the Subroutine and use the variable instead.
Dim Sheet as Worksheet
Set Sheet = ActiveSheet
.
Sheet.Range(...
.
Set Sheet = nothing
Look into reading/writing the data to a Variant instead of a range. (at least for the text manipulation) Here's an example of how to load a Range into a variant:
Dim vNoiseWords as Variant
vNoiseWords = Sheet.Range("B2", Sheet.Range("B2").End(xlDown)).Value2
Writing is just the opposite (but I usually have to transpose the array).
Then, you can go through the variant array and identify the text that needs to be coloured in the cell.
Minimize Any and All Interactions with the Sheet
...so limit any line that starts with ActiveSheet., Cell., Range. and only process it if it needs to be done.
Even Cell = UCase(Cell) is a huge waste of time.
Your much better off doing
Value = UCase(Cell.Value2)
If Value <> Cell.Value2 then Cell.Value2 = Value
Update
FYI, It's easy to pin point the slow parts of your code, by adding timestamps in between sections of code. Here is a simple routine that I use to keep track of time intervals and display the results in the immediate window.
Public Sub TimeStamp(Optional Prompt As String, Optional StartTimer As Boolean)
Static s_fTimer As Single, s_fIntervalTimer As Single
Dim fCurrTime As Single
fCurrTime = Timer
If StartTimer Then
s_fTimer = fCurrTime
s_fIntervalTimer = fCurrTime
End If
If Prompt <> vbNullString Then Prompt = " - " & Prompt
Debug.Print Format((fCurrTime - s_fTimer), "0.000s") & Format((fCurrTime - s_fIntervalTimer), "(0.000s)") & Prompt
s_fIntervalTimer = fCurrTime
End Sub
The first time you call it (or anytime you want to reset the total time counter), you should set the StartTimer = True like this:
TimeStamp "Start of Program", True
After that, just call the routine, with an optional prompt to keep track of the sections of code:
TimeStamp "After Smart Quote Loop"
TimeStamp "The End"
Then just look at the time intervals, find the largest ones and whittle them down if you don't think that they are reasonable. You'll find that every interaction with the UI/cells is the hold up, but processing data in the background takes very little time.