Hello Guys,
I have macro that uses the Dictionary Class in VBA to generate a list of words in a specific sheet and its frecuency. I want to improve on this and update a separate workbook that stores those frequencies each time they are run. I know I can take adavantage that everything is already stored in the dictionary so that it can arrange in the workbook the new "frequency".
Example:
My macro generates a list like this on a new sheet when the code runs:
<tbody>
</tbody>
I need that information also pasted in another workbook "WordFreq" in which I could log each time the macro was run.
So if in my workbook "WordFreq" I had the following:
<tbody>
</tbody>
I would like the macro to id if the word already exists and put that frequency in the correct row: if the word does not exists it should create it. so in the end it the result would be:
<tbody>
</tbody>
That way I could pivot results and identify trends!
My current code is as follows:
Thanks in advance for the help!
I have macro that uses the Dictionary Class in VBA to generate a list of words in a specific sheet and its frecuency. I want to improve on this and update a separate workbook that stores those frequencies each time they are run. I know I can take adavantage that everything is already stored in the dictionary so that it can arrange in the workbook the new "frequency".
Example:
My macro generates a list like this on a new sheet when the code runs:
| Word | Frequency |
| apple | 20 |
| banana | 15 |
| orange | 10 |
<tbody>
</tbody>
I need that information also pasted in another workbook "WordFreq" in which I could log each time the macro was run.
So if in my workbook "WordFreq" I had the following:
| Word | November-01 |
| apple | 50 |
| orange | 25 |
| peach | 5 |
<tbody>
</tbody>
I would like the macro to id if the word already exists and put that frequency in the correct row: if the word does not exists it should create it. so in the end it the result would be:
| Word | November-01 | November-14 |
| apple | 50 | 20 |
| orange | 25 | 10 |
| peach | 5 | 0 |
| banana | 0 | 15 |
<tbody>
</tbody>
That way I could pivot results and identify trends!
My current code is as follows:
Code:
Sub WordFrequency()
Dim Ws As Worksheet
Dim wsa As Worksheet
Dim X As Long, StopWords As Variant, Wrd As Variant, vNum As Variant, Txt As String
StopWords = Array("a", "about", "above", "above", "across", "after", "afterwards", "again", "against", "all", "almost", "alone", "along", "already", "also", "although", "always", "am", "among", "amongst", "amoungst", "amount", "an", "and", "another", "any", "anyhow", "anyone", "anything", "anyway", "anywhere", "are", "around", "as", "at", "back", "be", "became", "because", "become", "becomes", "becoming", "been", "before", "beforehand", "behind", "being", "below", "beside", "besides", "between", "beyond", "bill", "both", "bottom", "but", "by", "call", "can", "cannot", "cant", "co", "con", "could", "couldnt", "cry", "de", "describe", "detail", "do", "done", "down", "due", "during", "each", "eg", "eight", "either", "eleven", "else", "elsewhere", "empty", "enough", "etc", "even", "ever", "every", "everyone", "everything", "everywhere", "except", "few", "fifteen", "fifty", "fill", "find", "fire", "first", "five", "for", "former", "formerly", "forty", "found", _
"four", "from", "front", "full", "further", "get", "go", "had", "has", "hasnt", "have", "he", "hence", "her", "here", "hereafter", "hereby", "herein", "hereupon", "hers", "herself", "him", "himself", "his", "how", "however", "hundred", "ie", "if", "in", "inc", "indeed", "interest", "into", "is", "it", "its", "itself", "keep", "last", "latter", "latterly", "least", "less", "ltd", "made", "many", "may", "me", "meanwhile", "might", "mill", "mine", "more", "moreover", "most", "mostly", "move", "much", "must", "my", "myself", "name", "namely", "neither", "never", "nevertheless", "next", "nine", "no", "nobody", "none", "noone", "nor", "not", "nothing", "now", "nowhere", "of", "off", "often", "on", "once", "one", "only", "onto", "or", "other", "others", "otherwise", "our", "ours", "ourselves", "out", "over", "own", "part", "per", "perhaps", "please", "put", "rather", "re", "same", "see", "seem", "seemed", "seeming", "seems", "serious", "several", _
"she", "should", "show", "side", "since", "sincere", "six", "sixty", "so", "some", "somehow", "someone", "something", "sometime", "sometimes", "somewhere", "still", "such", "system", "take", "ten", "than", "that", "the", "their", "them", "themselves", "then", "thence", "there", "thereafter", "thereby", "therefore", "therein", "thereupon", "these", "they", "thickv", "thin", "third", "this", "those", "though", "three", "through", "throughout", "thru", "thus", "to", "together", "too", "top", "toward", "towards", "twelve", "twenty", "two", "un", "under", "until", "up", "upon", "us", "very", "via", "was", "we", "well", "were", "what", "whatever", "when", "whence", "whenever", "where", "whereafter", "whereas", "whereby", "wherein", "whereupon", "wherever", "whether", "which", "while", "whither", "who", "whoever", "whole", "whom", "whose", "why", "will", "with", "within", "without", "would", "yet", "you", "your", "yours", "yourself", "yourselves")
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Analysis").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set Ws = ActiveSheet
Sheets.Add.Name = "Analysis"
Set wsa = ActiveSheet
Ws.Select
Dim Found As Range, clm As Long
Set Found = Rows(1).Find(what:="SHORT_DESCRIPTION", LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then
MsgBox "Short_Description not found."
Exit Sub
End If
clm = Found.Column
Txt = Join(Application.Transpose(Range(Cells(2, clm), Cells(60000, clm))))
Txt = " " & LCase(Txt & " " & Join(Application.Transpose(Range(Cells(60001, clm), Cells(120000, clm))))) & " "
For X = 1 To Len(Txt)
If Mid(Txt, X, 1) Like "[!A-Za-z0-9]" Then Mid(Txt, X) = " "
Next
For Each Wrd In StopWords
Txt = Replace(Txt, " " & Wrd & " ", " ")
Next
For Each vNum In Array(64570081, 9841, 121, 13, 5, 3, 3, 2)
Txt = Replace(Txt, Space(vNum), " ")
Next
Wrd = Split(Txt)
With CreateObject("Scripting.Dictionary")
For X = 0 To UBound(Wrd)
If Len(Wrd(X)) > 2 Then .Item(Wrd(X)) = .Item(Wrd(X)) + 1
Next
On Error GoTo SomethingWentWrong
Application.ScreenUpdating = False
wsa.Cells(1, 1).Value = "Word"
wsa.Cells(1, 2).Value = "Frequency"
wsa.Range("A2:A" & .Count) = Application.Transpose(.Keys)
wsa.Range("B2:B" & .Count) = Application.Transpose(.Items)
End With
wsa.Select
Columns("A:B").Sort Columns("B"), xlDescending
ActiveSheet.ListObjects.Add(xlSrcRange, Range("a1").CurrentRegion, , xlYes).Name = _
"wrdf"
ActiveSheet.ListObjects("wrdf").TableStyle = "TableStyleLight2"
Columns("A:B").ColumnWidth = 15
SomethingWentWrong:
Application.ScreenUpdating = True
Beep
End SubThanks in advance for the help!
