40$ Word Macro Highlight Keywords And Maps Checklisted Words In A Listbox

[littleiitin]

Sri Save File as Macro enabled file.. Its Extension is .docm and docx

In previous file I have provided solution to highlight only complete word and not part of the word.

Please Use Below Code iN place of Previous One:

Sub CheckMove()
    
    Dim lngStart    As Long
    Dim lngCntFlag  As Long
    
    Application.ScreenUpdating = False
    Do
        If lngCntFlag <> 2 Then
            lngStart = Selection.Start
            Selection.Move unit:=wdWord
            Selection.MoveRight unit:=wdWord, Extend:=wdExtend
            If Selection.Bookmarks.Exists("\EndOfDoc") = True Then
                lngCntFlag = lngCntFlag + 1
                Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
            End If
            If Selection.Font.Color = wdColorGreen And Selection.Range.HighlightColorIndex = wdYellow Then
                Exit Sub
            End If
        Else
            Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
            MsgBox "There is no highlighted Keyword in file."
            
            Exit Sub
        End If
        
    Loop
    Application.ScreenUpdating = True
End Sub

Thanks
Rahul Kumar singh

[littleiitin]

Please Replace This Code:

Sub SelectAllKeywords()
    
    Dim objExcel        As Object
    Dim wbkExcel        As Object
    Dim wksAct          As Object
    Dim wksCheck        As Object
    Dim rngWhole        As Object
    Dim rngCell         As Object
    Dim strSearch       As String
    Dim rngRange        As Range
    Dim lngRow          As Long
    Dim lngcol          As Long
    Dim lngRowN         As Long
    Dim lngcolN         As Long
    Dim lngTableCre     As Double
    Dim lngTableFlag    As Long
    Dim strFilePath     As String
    Dim rngCheck        As Object
    Dim rngKey          As Object
    Dim wksNew          As Object
    Dim rngFin          As Object
    Dim lngCntr         As Long
    Dim tblTable        As Table
    Dim lngTblID        As Long
    
    Application.ScreenUpdating = False
    For Each tblTable In ActiveDocument.Tables
        lngTblID = lngTblID + 1
        tblTable.ID = lngTblID
    Next
    
    Set objExcel = CreateObject("Excel.Application")
   
    strFilePath = FilePicker
    If strFilePath = "" Then
        GoTo Xit
    End If
    objExcel.Visible = True
    Set wbkExcel = objExcel.workbooks.Open(strFilePath)
    Set wksAct = wbkExcel.worksheets("KeyWord")
    Set wksCheck = wbkExcel.worksheets("Checklist")
    

    With wksAct
        Set rngKey = wksAct.Application.Intersect(.UsedRange, .UsedRange.Offset(1))
        varKeywords = rngKey
        Set rngWhole = rngKey.Columns(rngKey.Columns.Count)
    End With
    With wksCheck
        Set rngCheck = wksCheck.Application.Intersect(.UsedRange, .UsedRange.Offset(1))
        varCheck = rngCheck
    End With
    wbkExcel.Sheets.Add After:=wbkExcel.Sheets(wbkExcel.Sheets.Count)
    Set wksNew = wbkExcel.activesheet
    With wksNew
        rngCheck.Copy .Range("A2")
'        .Range("A2").PasteSpecial xlpasteall
        .Range("C2").Value = "=Vlookup(A2," & rngKey.Address(, , , 1) & ",2)"
        .Range("D2").Value = "=B2"
        Set rngFin = .Range("C2:D" & rngCheck.Rows.Count + 1)
        rngFin.filldown
        With ThisDocument.ListBox11
            .Clear
            .ColumnCount = 2
            For lngCntr = 1 To rngFin.Rows.Count - 1
                .AddItem rngFin.Columns(1).Cells(lngCntr)
                .List(lngCntr - 1, 1) = CStr(rngFin.Columns(2).Cells(lngCntr).Value)
            Next
        End With
    End With
    ThisDocument.ListBox11.Height = 1
    ThisDocument.ListBox11.Width = 1
    Set rngRange = ActiveDocument.Range
    Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
    ThisDocument.ListBox1.Clear
    ThisDocument.ListBox12.Clear
    For Each rngCell In rngWhole.Cells
        ThisDocument.ListBox1.AddItem rngCell.Value
        Do
            Selection.Find.ClearFormatting
            Selection.Find.Text = rngCell.Value
            Selection.Find.MatchWholeWord = True
            strSearch = rngCell.Value
            Selection.Find.MatchWholeWord = True
            Selection.Find.Execute
            If Selection.Information(wdWithInTable) = True Then
                If Selection.Tables(1).ID <> lngTableCre Or (Selection.Tables.Parent.Cells(1).ColumnIndex <> lngcol Or Selection.Tables.Parent.Cells(1).RowIndex <> lngRow) Then
                    lngTableFlag = 0
                    lngcol = 0
                    lngRow = 0
                    lngTableCre = 0
                End If
            End If
            If lngcol = 0 And lngRow = 0 And lngTableCre = 0 Then
                Selection.Font.Color = wdColorGreen
                Selection.Range.HighlightColorIndex = wdYellow
            End If
            If Selection.Information(wdWithInTable) = True Then
                If Selection.Tables(1).ID <> lngTableCre Or (Selection.Tables.Parent.Cells(1).ColumnIndex <> lngcol Or Selection.Tables.Parent.Cells(1).RowIndex <> lngRow) Then
                    lngcol = Selection.Tables.Parent.Cells(1).ColumnIndex
                    lngRow = Selection.Tables.Parent.Cells(1).RowIndex
                    lngTableCre = Selection.Tables(1).ID
                    lngTableFlag = 1
                End If
            End If
            If Selection.Information(wdWithInTable) = True Then
                If Selection.Tables.Parent.Cells(1).ColumnIndex <> lngcol Or Selection.Tables.Parent.Cells(1).RowIndex <> lngRow Then
                    Selection.Font.Color = wdColorGreen
                    Selection.Range.HighlightColorIndex = wdYellow
                End If
            End If
           
        Loop While Selection.Find.Found
        Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""

        lngTableFlag = 0
        lngcol = 0
        lngRow = 0
        lngTableCre = 0
    Next
    wbkExcel.Close 0
    Set wbkExcel = Nothing
Xit:
    objExcel.Quit
    Application.ScreenUpdating = True
    
End Sub