VBA to remove specified words and characters

[dorkus]

Hi All!

Please could i have some help updating the below VBA to also remove a specified list of phrases and characters (such as "To", "the", "**" etc)
The code counts the frequency of words in all content in column A. It splits column A into text to columns, then puts the contents of each column below the last value in column A and then runs a count function.

Sub WordCounter()

Dim lastRow&, i&, ResultsLastRow&
Dim rawWS As Worksheet, ResultsWS As Worksheet

Set rawWS = ActiveSheet
Set ResultsWS = Sheets.Add
ResultsWS.Name = "Results"
rawWS.Activate

'ResultsWS.Columns(1).Value = rawWS.Columns(1).Value
ResultsLastRow = 1

With rawWS
    .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
                                  Semicolon:=False, Comma:=False, Space:=True, Other:=False, TrailingMinusNumbers:=True

    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = lastRow To 1 Step -1
        .Rows(i).EntireRow.Copy
        ResultsWS.Range("A" & ResultsLastRow).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        ' ResultsWS.Range ("A" & ResultsLastRow)
        ResultsLastRow = ResultsWS.Cells(ResultsWS.Rows.Count, 1).End(xlUp).Row + 1
    Next i
    Application.CutCopyMode = False
End With

With ResultsWS
    ' get unique words and run a count
    .Range("A:A").Copy .Range("C:C")
    .Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    ResultsLastRow = .Cells(.Rows.Count, 3).End(xlUp).Row

    .Range(.Cells(1, 4), .Cells(ResultsLastRow, 4)).FormulaR1C1 = "=COUNTIF(C[-3],RC[-1])"
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("D1:D1048576") _
                              , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("C1:D1048576")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End With


End Sub

Thanks in advance

 

[Fluff]

How about

Sub dorkus()
   Dim Ary As Variant, Critary As Variant, Sp As Variant
   Dim i As Long, j As Long
   
   Critary = Array("to", "the", "**", "&", "and", "all")
   Ary = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value2
   With CreateObject("scripting.dictionary")
      .CompareMode = 1
      For i = 1 To UBound(Ary)
         Sp = Split(Ary(i, 1))
         For j = 0 To UBound(Sp)
            If Not .Exists(Sp(j)) Then
               If Not UBound(Filter(Critary, Sp(j), True, 1)) >= 0 Then .Add Sp(j), 1
            Else
               .Item(Sp(j)) = .Item(Sp(j)) + 1
            End If
         Next j
      Next i
      Sheets.Add.Name = "Results"
      Range("C1").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
   End With
   Range("C1").CurrentRegion.Sort key1:=Range("D1"), Order1:=xlDescending, Header:=xlNo
End Sub