[FONT=Lucida Console][COLOR=Royalblue]Sub[/COLOR] regexWordFrequency()
[I][COLOR=Dimgray]'word frequency[/COLOR][/I]
[I][COLOR=Dimgray]'Put the data in col A, run the code, the result is in col D:E.[/COLOR][/I]
[I][COLOR=Dimgray]'tested on a text (from a novel) with 161K words, it took 1.2 seconds[/COLOR][/I]
[COLOR=Royalblue]Dim[/COLOR] regEx [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR], matches [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR], x [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR], d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] obj [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]New[/COLOR] DataObject
[COLOR=Royalblue]Dim[/COLOR] tx [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR], z [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] t, q, va
[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
t = Timer
Range([COLOR=Darkcyan]"A1"[/COLOR], Cells(Rows.count, [COLOR=Darkcyan]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp)).Copy
obj.GetFromClipboard
tx = obj.GetText
Application.CutCopyMode = False
tx = Replace(tx, [COLOR=Darkcyan]"'"[/COLOR], [COLOR=Darkcyan]"___"[/COLOR])
[COLOR=Royalblue]Set[/COLOR] regEx = CreateObject([COLOR=Darkcyan]"VBScript.RegExp"[/COLOR])
[COLOR=Royalblue]With[/COLOR] regEx
.[COLOR=Royalblue]Global[/COLOR] = True
.MultiLine = True
.IgnoreCase = True
.pattern = [COLOR=Darkcyan]"\w+"[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]
[COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=Darkcyan]"scripting.dictionary"[/COLOR])
d.CompareMode = vbTextCompare
[COLOR=Royalblue]Set[/COLOR] matches = regEx.Execute(tx)
[COLOR=Royalblue]For[/COLOR] [COLOR=Royalblue]Each[/COLOR] x In matches
d([COLOR=Royalblue]CStr[/COLOR](x)) = d([COLOR=Royalblue]CStr[/COLOR](x)) + [COLOR=Brown]1[/COLOR]
[COLOR=Royalblue]Next[/COLOR]
[COLOR=Royalblue]If[/COLOR] d.count = [COLOR=Brown]0[/COLOR] [COLOR=Royalblue]Then[/COLOR] MsgBox [COLOR=Darkcyan]"[COLOR=Royalblue]Nothing[/COLOR] found"[/COLOR]: [COLOR=Royalblue]Exit[/COLOR] [COLOR=Royalblue]Sub[/COLOR]
[I][COLOR=Dimgray]'put the result in col D:E[/COLOR][/I]
Range([COLOR=Darkcyan]"D:E"[/COLOR]).ClearContents
[COLOR=Royalblue]With[/COLOR] Range([COLOR=Darkcyan]"D2"[/COLOR]).Resize(d.count, [COLOR=Brown]2[/COLOR])
[COLOR=Royalblue]If[/COLOR] d.count < [COLOR=Brown]65536[/COLOR] [COLOR=Royalblue]Then[/COLOR] [I][COLOR=Dimgray]'Transpose function has a limit of 65536 item to process[/COLOR][/I]
.Value = Application.Transpose(Array(d.Keys, d.items))
[COLOR=Royalblue]Else[/COLOR]
[COLOR=Royalblue]ReDim[/COLOR] va([COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] d.count, [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Brown]2[/COLOR])
i = [COLOR=Brown]0[/COLOR]
[COLOR=Royalblue]For[/COLOR] [COLOR=Royalblue]Each[/COLOR] q In d.Keys
i = i + [COLOR=Brown]1[/COLOR]
va(i, [COLOR=Brown]1[/COLOR]) = q: va(i, [COLOR=Brown]2[/COLOR]) = d(q)
[COLOR=Royalblue]Next[/COLOR]
.Value = va
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
.Replace what:=[COLOR=Darkcyan]"___"[/COLOR], Replacement:=[COLOR=Darkcyan]"'"[/COLOR], LookAt:=xlPart, SearchFormat:=False, ReplaceFormat:=False
.Sort Key1:=.Cells([COLOR=Brown]1[/COLOR], [COLOR=Brown]2[/COLOR]), Order1:=xlDescending, Key2:=.Cells([COLOR=Brown]1[/COLOR], [COLOR=Brown]1[/COLOR]), Order2:=xlAscending, Header:=xlNo
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]
Range([COLOR=Darkcyan]"D1"[/COLOR]) = [COLOR=Darkcyan]"WORD"[/COLOR]
Range([COLOR=Darkcyan]"E1"[/COLOR]) = [COLOR=Darkcyan]"FREQUENCY"[/COLOR]
Range([COLOR=Darkcyan]"D:E"[/COLOR]).Columns.AutoFit
Debug.Print Timer - t
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]