What you want is indeed possible - copy the following code into a Word module
and run the macro FindAndCount.
This application is bare bones but could be adapated to your needs. It will
get a list of words either from an Excel spreadsheet or by prompting you,
then counts those words in whatever document is active.
If you're pulling your list of words from a spreadsheet, this code requires
that the list start in cell A1 and be in a single column. The workbook needs
to be saved as "c:\mylist.xls". Obviously those kinds of details could be
fine tuned but they're hard coded here to keep things simple.
Similarly the output spreadsheet with the word list and count and chart
could be formatted any way you wanted, but that would require customising the
code. Again, this code is bare bones to keep things simple.
Let me know if you have any questions.
Option Explicit
Sub FindAndCount()
Dim rngStory As Range
Dim arrListArray() As String
Dim arrCounterArray
Dim i As Long
Dim varResponse As Variant
varResponse = MsgBox("Get words from Excel? " & _
"If no you will be prompted for words.", _
vbYesNoCancel)
If varResponse = vbCancel Then
Exit Sub
End If
ReDim arrListArray(0)
arrListArray = GetWordsToCount(arrListArray, varResponse)
WordBasic.sortarray arrListArray
ReDim arrCounterArray(UBound(arrListArray), 1)
For i = 0 To UBound(arrListArray)
arrCounterArray(i, 0) = arrListArray(i)
Next
For Each rngStory In ActiveDocument.StoryRanges
'if you only want to search document main body
'change "< 4" in following line to "= 1"
'otherwise this checks footnotes and endnotes too
If rngStory.StoryType < 4 Then
If rngStory.StoryLength >= 2 Then
arrCounterArray = SearchAndCountInStory( _
rngStory, _
arrCounterArray)
End If
Set rngStory = rngStory.NextStoryRange
End If
Next
FillExcelChart arrCounterArray
End Sub
Public Function SearchAndCountInStory( _
ByVal rngStory As Word.Range, _
ByRef arrCounterArray As Variant)
Dim i As Long
Dim j As Long 'counts indexing action for each term in array
Dim fldIndexEntry As Field
For i = 0 To UBound(arrCounterArray, 1)
Selection.HomeKey Unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = True
.Wrap = wdFindStop
.Text = arrCounterArray(i, 0)
While .Execute
arrCounterArray(i, 1) = arrCounterArray(i, 1) + 1
Wend
End With
rngStory.Expand Unit:=wdStory
Next i
SearchAndCountInStory = arrCounterArray
End Function
Function GetWordsToCount( _
ByRef arrListArray As Variant, _
ByVal varResponse As Variant)
On Error GoTo errorhandler
Select Case varResponse
Case vbYes
GoSub GetWordsFromExcel
Case vbNo
GoSub GetWordsPrompted
End Select
GetWordsToCount = arrListArray
Exit Function
GetWordsFromExcel:
Dim objExcel As Object
Dim objMyList As Object
Dim n As Long
Dim r As Long
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objMyList = objExcel.Workbooks.Open("c:\mylist.xls")
r = objMyList.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
ReDim arrListArray(r - 1)
For n = 1 To r
arrListArray(n - 1) = objMyList.Worksheets(1).Cells(n, 1)
Next n
objMyList.Close False
objExcel.Application.Quit
Set objMyList = Nothing
Set objExcel = Nothing
Return
GetWordsPrompted:
arrListArray(UBound(arrListArray)) = _
InputBox("What word do you want to count?")
If MsgBox("Any more words you want to search for?", _
vbYesNo) = vbYes Then
GoSub IncreaseArrayForPrompts
GoSub GetWordsPrompted
End If
Return
IncreaseArrayForPrompts:
ReDim Preserve arrListArray(UBound(arrListArray) + 1)
Return
Exit Function
errorhandler:
If objExcel Is Nothing Then
'do nothing
Else
objExcel.Application.Quit
Set objExcel = Nothing
End If
MsgBox Err.Number & " " & Err.Description
End Function
Sub FillExcelChart(ByRef arrCounterArray As Variant)
On Error GoTo errorhandler
Dim objExcel As Object
Dim i As Long
Dim x As Long
Dim rngRange As Range
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add
objExcel.Workbooks.Add
x = 1 'set Excel record counter
For i = 0 To UBound(arrCounterArray)
With objExcel.Worksheets(1)
.Cells(x, 1).Value = arrCounterArray(x - 1, 0)
.Cells(x, 2).Value = arrCounterArray(x - 1, 1)
End With
x = x + 1 'increment Excel counter
Next i
objExcel.Worksheets(1).Range("A1").CurrentRegion.Select
With objExcel
.Charts.Add
.ActiveChart.ChartType = xlColumnClustered
.ActiveChart.SetSourceData _
Source:=.Worksheets(1).Range("A1").CurrentRegion
.ActiveChart.Location _
Where:=xlLocationAsObject, _
Name:="Sheet1"
End With
Set objExcel = Nothing
Exit Sub
errorhandler:
If objExcel Is Nothing Then
'do nothing
Else
objExcel.Application.Quit
Set objExcel = Nothing
End If
MsgBox Err.Number & " " & Err.Description
Exit Sub
End Sub
