[mohanjackie]

I am week in creating macro
I tried all sort of ideas and add-ins, I couldn't find the solution

How can i find list of word occurred in doc(Microsoft word)

List of word is in excel A row

eg:

MAN
i am tiger
The wolf

So, the macro needs to find number of times this keywords occurred in the article situated in doc in the same folder

I found a code while searching google, but it only stats true or false

[mohanjackie]

This problem solved in another fourm

i am sharing it in the purpose of any other seekers can make use of it.

This the vba i was looking for, both works good

Thanks to karedog and sktneer for this wonderful code specially used for seo purpose

VBA 1 by:karedog

Sub Test()
  Dim a, i As Long, strContent As String
  With CreateObject("Word.Application")
    With .Documents.Open(ThisWorkbook.Path & "\doc.docx")
      strContent = .Content.Text
      .Close
    End With
    .Quit
  End With
  With Sheets("Keyword Tool Export - Check Sea").Range("A1").CurrentRegion
    a = .Value
    With CreateObject("VBScript.RegExp")
      .Global = True
      .IgnoreCase = True
      For i = 2 To UBound(a, 1)
          .Pattern = Replace$(a(i, 1), ".", "\.")
          If .Test(strContent) Then a(i, 2) = .Execute(strContent).Count
      Next i
    End With
    .Value = a
  End With 
End Sub

VBA 2 by: sktneer

Sub WordCount() 
    Dim SelectedFile As String 
    Dim wdApp As Object 
    Dim Doc As Object 
    Dim WordToCount As String 
    Dim Cnt As Integer, lr As Long 
    Dim Rng As Range, Cell As Range 
     
    Application.ScreenUpdating = False 
     
    With Application.FileDialog(msoFileDialogFilePicker) 
        .Title = "Select The Word Document!" 
        .ButtonName = "Confirm" 
        .Filters.Clear 
        .Filters.Add "Word Documents", "*.docx" 
        If .Show = -1 Then 
            SelectedFile = .SelectedItems(1) 
        Else 
            MsgBox "You didn't select a document.", vbExclamation, "Document Not Selected!" 
            Exit Sub 
        End If 
    End With 
     
    lr = Cells(Rows.Count, 1).End(xlUp).Row 
    Set Rng = Range("A2:A" & lr) 
     
    Set wdApp = CreateObject("Word.Application") 
     
    Set Doc = wdApp.documents.Open(SelectedFile) 
     
    For Each Cell In Rng 
        Cnt = 0 
        With wdApp.Selection 
            .HomeKey Unit:=6 
            With .Find 
                .ClearFormatting 
                .Text = Cell.Value 
                Do While .Execute 
                    Cnt = Cnt + 1 
                    wdApp.Selection.MoveRight 
                Loop 
            End With 
        End With 
        Cell.Offset(0, 1).Value = Cnt 
    Next Cell 
    Application.ScreenUpdating = True 
     
Skip: 
    wdApp.Quit 
    Set Doc = Nothing 
    Set wdApp = Nothing 
    MsgBox "Task completed.", vbInformation, "Done!" 
End Sub