Hi NinjaNeko,

Dumping it in a text would be better, couting the number of line will you
the count of the words. and in the end generate the graph in excel with the
data.

I hope this was helpful

Anand

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

PS - credit where credit due: the code I posted incorporated bits of code
developed in another thread by Greg Maxey & myself.