I found this vba-code on net and I've tried to adjust so it only search for words with capitalized first letter. My problem is that I don't even can get it to list all words so it match case from the orginal documents.
I have tried to
SingleWord = Trim(LCase(aWord))
with
Is there anyone who can help me with this issue?
Here is the code;
Option Explicit
Function GetFolder(Optional Title As String = "Select a Folder", Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function
Sub LoopAll()
Dim strPath As String
Dim strFile As String
Dim oCurDoc As Document
Dim oDoc As Document
Dim oTempDoc As Document
Dim Ans As String
'Word Breaker variables
Dim TotalWords As Long
Dim SingleWord As String 'Raw word pulled from doc
Const MaxWords = 9000 'Maximum unique words allowed
Dim Words(MaxWords) As String 'Array to hold unique words
Dim Freq(MaxWords) As Integer 'Frequency counter for Unique Words
Dim WordNum As Integer 'Number of unique words
Dim ByFreq As Boolean 'Flag for sorting order
Dim ttlwds As Long 'Total words in the document
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'Temporary variables
Dim tword As String '
Dim thisDoc As String
Dim Excludes As String 'Words to be excluded
Dim aWord As Range
On Error GoTo ErrHandler
Set oCurDoc = Documents.Add
'strPath = "C:\Word\" ' note the trailing \
'strPath = "D:\Data\TestFolder\" ' note the trailing \
strPath = InputBox$("Enter Path (ex: D:\data\testfolder\ - note trailing \)", "Data Path", "D:\data\testfolder\")
'strPath = GetFolder(Title:="Find a Folder", RootFolder:=&H11) & ""
'strFile = Dir(strPath & "*.doc") 'word docs only
'strFile = Dir(strPath & "*.*") 'scan all files
strFile = Dir(strPath & InputBox$("Enter File Extensions to scan", "File types", "*.docx"))
' Set up excluded words ... edit the list below.
Excludes = "[a][also][an][and][are][as][at][be][by]" & vbCrLf
Excludes = Excludes & "[for][if][in][is][it][its][of][on][or][so]" & vbCrLf
Excludes = Excludes & "[then][there][them][the][this][that][to][you]" & vbCrLf
Excludes = Excludes & InputBox$("The following words are excluded: " & Excludes & _
".Enter any other words that you wish to exclude, surrounding each word with [ ].", _
"Excluded Words", "")
' Find out how to sort
ByFreq = True
Ans = InputBox$("Sort by WORD or by FREQ?", "Sort order", "WORD")
If Ans = "" Then
Exit Sub
End If
If UCase(Ans) = "WORD" Then
ByFreq = False
End If
System.Cursor = wdCursorWait
Application.ScreenUpdating = False
Do While Not strFile = ""
' Open document
Set oDoc = Documents.Open(FileName:=strPath & strFile, AddToRecentFiles:=False)
thisDoc = oDoc.Name
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'This code compiles a sorted table showing the frequency with which
'any given word appears in a document. Words not required for inclusion in
'the count can be excluded.
'Adapted from code by macropod on WOPR.com by Chalmers Davis
'20030820
Selection.HomeKey Unit:=wdStory
WordNum = 0
ttlwds = ActiveDocument.Words.Count
TotalWords = ActiveDocument.Words.Count
Selection.Range.Case = wdTitleWord
' Control the repeat
For Each aWord In ActiveDocument.Words
SingleWord = Trim(LCase(aWord))
' SingleWord = Trim(aWord)
If (Left(SingleWord, 1) = "'") And (Len(SingleWord) > 1) Then
SingleWord = Mid(SingleWord, 2) 'trash that leading apostrophe
If Right(SingleWord, 1) = "'" Then 'drop any trailing one, too.
SingleWord = Left(SingleWord, Len(SingleWord) - 1)
End If
Else
If SingleWord < "a" Or SingleWord > "z" Then SingleWord = "" 'Out of range?
End If
If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = "" 'On exclude list?
If Len(SingleWord) > 0 Then
Found = False
For j = 1 To WordNum
If Words(j) = SingleWord Then
Freq(j) = Freq(j) + 1
Found = True
Exit For
End If
Next j
If Not Found Then
WordNum = WordNum + 1
Words(WordNum) = SingleWord
Freq(WordNum) = 1
End If
If WordNum > MaxWords - 1 Then
MsgBox "The maximum array size has been exceeded. Increase maxwords.", vbExclamation
Exit For
End If
End If
ttlwds = ttlwds - 1
StatusBar = "Remaining: " & ttlwds & " Unique: " & WordNum
Next aWord
' Now sort it into word order
For j = 1 To WordNum - 1
k = j
For l = j + 1 To WordNum
If (Not ByFreq And Words(l) < Words(k)) Or (ByFreq And Freq(l) > Freq(k)) Then k = l
Next l
If k <> j Then
tword = Words(j)
Words(j) = Words(k)
Words(k) = tword
Temp = Freq(j)
Freq(j) = Freq(k)
Freq(k) = Temp
End If
StatusBar = "Sorting: " & WordNum - j
Next j
' Close document without saving it
oDoc.Close SaveChanges:=wdDoNotSaveChanges
' Now write out the results
Set oTempDoc = Documents.Add ' write results to this document
Selection.ParagraphFormat.TabStops.ClearAll
With Selection
For j = 1 To WordNum
.TypeText Text:=Words(j) & vbTab & Trim(Str(Freq(j))) & vbCrLf
Next j
End With
oTempDoc.Range.Select
Selection.ConvertToTable
Selection.Collapse wdCollapseStart
With oTempDoc.Tables(1)
.Rows.Add BeforeRow:=Selection.Rows(1)
'Insert filename in first row
.Cell(1, 1).Range.InsertBefore "Title"
.Cell(1, 2).Range.InsertBefore thisDoc
.Rows.Add
.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Rows.Add
.Cell(ActiveDocument.Tables(1).Rows.Count, 1).Range.InsertBefore _
"Total words in Document"
.Cell(ActiveDocument.Tables(1).Rows.Count, 2).Range.InsertBefore TotalWords
.Rows.Add
.Cell(ActiveDocument.Tables(1).Rows.Count, 1).Range.InsertBefore _
"No. of different words"
.Cell(ActiveDocument.Tables(1).Rows.Count, 2).Range.InsertBefore _
Trim(Str(WordNum))
'Adjust column withs with AutoFit
.Columns.AutoFit
.Range.Copy
End With
'Run Spell Checker
'For i = ActiveDocument.SpellingErrors.Count To 1 Step -1
' SendKeys "%c"
' ActiveDocument.SpellingErrors(i).CheckSpelling
'Next i
oCurDoc.Activate
Selection.EndKey Unit:=wdStory
Selection.Paste
Selection.InsertBreak Type:=wdPageBreak
oTempDoc.Close SaveChanges:=wdDoNotSaveChanges
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
strFile = Dir
Loop
ExitHandler:
' Cleaning up
Selection.HomeKey wdStory
System.Cursor = wdCursorNormal
Application.ScreenUpdating = True
Set aWord = Nothing
Set oCurDoc = Nothing
Set oTempDoc = Nothing
Set oDoc = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub