Please Replace This Code:
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
Bookmarks