Word VBA_find string against bullet point

[Mahesh]

I have table (Row:10, column:2) in word document, 2nd column of row 10, contain text with bullet points,
again undersome bullet point there is multilevel lists as mentioned below.

Steps;
1. create new excel document (wb2)
2. Go back to main word file (wb1) with table (Row:10,Col:2)
3. Pop Up InputBox, user will input search string "ABC"
4. search text "ABC" against bullet point if found copy on (wb2- column A)
5. If again there is multilevel list under bullet point
6. search "USD" if found copy USD amount to (wb2 - column B)
7. search "Location" if found Location to (wb2 - column C)

i do post here also.
www.excelforum.com/word-formatting-and-general/1214488-word-vba_find-string-against-bullet-point.html#post4815387
www.msofficeforums.com/word-vba/37872-word-vba_find-string-against-bullet-point.html
www.excelfox.com/forum/showthread.php/2219-Word-VBA_find-string-against-bullet-point
www.vbaexpress.com/forum/forumdisplay.php?20-Word-Help]

I will appreciate any assistance to edit below code;

Sub test()
Dim TargetText As String, StrMsg As String
Dim Col As Long, i As Long, j As Long, Rng As Range
With Selection
If .Information(wdWithInTable) = False Then
MsgBox "The cursor must be within a table cell.", , "Cursor outside table"
Exit Sub
Else
Col = .Cells(1).ColumnIndex
TargetText = InputBox("Enter text to search. " & _
"This macro will search the column you have " & _
"selected for this text and count how many " & _
"times it appears in that column. Do you want to continue?", _
"Enter text to find and count")
With .Tables(1)
For i = 1 To .Rows.Count
Set Rng = .Cell(i, Col).Range
With .Cell(i, Col).Range

With .Find
.ClearFormatting
.Text = TargetText
'.Replacement.ClearFormatting ''Clear existing formatting and settings in Find feature.
.Replacement.Highlight = True 'Set highlight to replace setting.
.Replacement.Text = ""
'.Replacement.
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With


Do While .Find.Found
If .Duplicate.InRange(Rng) Then
j = j + 1
.Collapse wdCollapseEnd
.Find.Execute
Else
Exit Do
End If
Loop
End With
Next
End With
Select Case j
Case 0: StrMsg = "The text " & TargetText & " was not found in the selected column "
Case 1: StrMsg = "There is 1 occurrence of the text " & TargetText & " in the selected column "
Case Else: StrMsg = "There are " & j & " occurrences of the text '" & TargetText & "' in the selected column "
End Select
MsgBox StrMsg & Col & ".", , "Text search in column"
End If
End With
End Sub