Need a Help for Alter the VBA code

[kissisvarmas]

Hi,
I need a help to alter this code, currently this code is extracting the sentences which having the strings from the document "Current.docx" and pasting in "Guidance.docx".Instead of that, i want to custom my code to highlight and color the whole sentences which having strings in the "Current.docx" itself, no need to use "Guidance.docx" for extraction. and the given color should combination of two(for sentence one color and string include in the sentence should be another color). please find the example below

example:
If i use the only "estimate" string in the above code
sample sentences:
For nine months, net sales increased 9% to 100 Million. in the first nine months of fiscal 2016, up from $604.4 million in the first nine months of fiscal 2015. Operating income increased 10% to $124.4 million, up from $107.5 million in the first nine months of fiscal 2015.
With respect to the remainder of fiscal 2016, the company continues to estimate the full year net sales growth to be between 8% - 10%. And the full is exactly in line with consensus

After Code the result could be: ( Image file open in new tab)


17125


So some one Please alter the below code to get the result as above manner




Sub guidance()
Const strFind As String = "outlook/guidance/forecast/achiev/anticipat/believe/between/estimate/expect/goal/intend/may/object/plan/predict/project/range/sees/should/target/will/approx/preliminary/budget/reaffirm"
Dim guid1 As Document
Dim guid2 As Document
Dim vFind As Variant
Dim dic As Object
Dim s As Variant
Dim i As Long

Set guid1 = Documents("Current.docx")
Set guid2 = Documents("Guidance.docx")
vFind = Split(strFind, "/")

Set dic = CreateObject("scripting.dictionary")

For Each s In guid1.Sentences
For i = LBound(vFind) To UBound(vFind)
If InStr(LCase(s.Text), vFind(i)) > 0 Then
dic(Trim(s.Text)) = Empty
End If
Next
Next



guid2.Range.Text = Join(dic.keys, vbCr)
guid2.Activate


End Sub

[gmaxey]

Probably not the most efficient, but here is one way:

Sub guidance()
'Const strFind As String = "outlook/guidance/forecast/achiev/anticipat/believe/between/estimate/expect/goal/intend/may/object/plan/predict/project/range/sees/should/target/will/approx/preliminary/budget/reaffirm"
Const strFind As String = "estimate/expect"
Dim oDoc As Document
Dim vFind As Variant
Dim s As Range
Dim i As Long
Dim oWord As Range
Set oDoc = ActiveDocument
vFind = Split(strFind, "/")
For Each s In oDoc.Sentences
For i = LBound(vFind) To UBound(vFind)
If InStr(LCase(s.Text), vFind(i)) > 0 Then
s.HighlightColorIndex = wdYellow
Set oWord = s
oWord.Start = s.Start + InStr(LCase(s.Text), vFind(i)) - 1
oWord.End = oWord.Start + Len(vFind(i))
oWord.Font.ColorIndex = wdRed
End If
Next i
Next s
lbl_Exit:
Exit Sub
End Sub

[kissisvarmas]

Thanks, Gmaxey, the code is working, but here only one string is getting highlighted with red color, but remaining stings are not highlighted. so can you please alter the code which highlights all the remaining strings with in the sentences.
17126

in the above document only "between" string is highlighted with red color, i need to highlight "estimate" too with red color.

[gmaxey]

Even less efficient:


Sub guidance()
Const strFind As String = "outlook/guidance/forecast/achiev/anticipat/believe/between/estimate/expect/goal/intend/may/object/plan/predict/project/range/sees/should/target/will/approx/preliminary/budget/reaffirm"
'Const strFind As String = "estimate/expect"
Dim oDoc As Document
Dim vFind As Variant
Dim s As Range
Dim i As Long
Dim oWord As Range
Set oDoc = ActiveDocument
vFind = Split(strFind, "/")
For i = LBound(vFind) To UBound(vFind)
For Each s In oDoc.Sentences

If InStr(LCase(s.Text), vFind(i)) > 0 Then
s.HighlightColorIndex = wdYellow
Set oWord = s
oWord.Start = s.Start + InStr(LCase(s.Text), vFind(i)) - 1
oWord.End = oWord.Start + Len(vFind(i))
oWord.Font.ColorIndex = wdRed
End If
Next s
Next i
lbl_Exit:
Exit Sub
End Sub


You need to start trying to solve these issues yourself. This is not a free code writing service. When you provide example text, don't send a picture without the corresponding text. I have better things to do than spend my time typing out your examples.

[kissisvarmas]

Thanks maxey for giving the support...the code is working now...any way sorry for troubling you...