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

```