Looking for suggestions how to make my functional but ugly hack jobcode elegant

[-W]

Hello all;

First time poster here. What I'm trying to do is search through a
document targeting on a keyword (entered by the user). When the
keyword is found, the code then uses the Extend and wdMove objects to
Select the sentence that the key word is in copy it and paste it at
the bottom of the document.

The code below works, but is definitely newbie hack code. I'm sure
that there is a much more elegant way to do this. I would appreciate
any suggestions. I'm much better at VBA for Excel.

Also looking for;
Once I find the sentence I want, I would like to then scan up in the
document to where a style change is and copy that also. (Heading 3
vs. Normal)

Example: search word = "shall"

Desired result
2.3.1 Byte Control Parameter <tab> When the Byte Control Parameter is
False the system shall send BCPerror to Master <vbCr>

'''''''''''''''''''
' Code Begins
''''''''''''''''''
Public Sub Gobbeldygook()

Dim strSearch As String
strSearch = InputBox$("Type in the text you want to search for.")


Dim iCount As Long
Dim jCount As Long

iCount = 0
Selection.HomeKey Unit:=wdStory

Selection.HomeKey Unit:=wdStory
With ActiveDocument.Content.Find
.Text = strSearch
.Format = False
.Wrap = wdFindStop
'Uses Do While here
Do While .Execute
iCount = iCount + 1
Loop '
End With
crap = MsgBox(iCount, vbOKOnly)

If iCount = 0 Then
End
End If

jCount = 0
With ActiveDocument.Content.Find
.ClearFormatting
Do While .Execute(FindText:=strSearch, Forward:=True, _
Format:=True) = True
With .Parent
.StartOf Unit:=wdSentence, Extend:=wdMove
'.InsertAfter vbCr
.EndOf Unit:=wdSentence, Extend:=wdExtend
.Select
.Copy
.Move Unit:=wdSentence, Count:=1
.Bold = True
End With
strRetTextName = Selection.Text & vbCr
Selection.EndKey Unit:=wdStory
Selection.Text = strRetTextName
Selection.Paste
'
jCount = jCount + 1
If jCount = iCount Then
crap = MsgBox(jCount, vbOKOnly)
End
End If
Loop
End With
crap = MsgBox(iCount, vbOKOnly)
End Sub

 

[StevenM]

To: W,

The first part of your task is easy enough:

Sub FindSentenceOfKeyWordOrPhrase()
Dim key As String
Dim str As String
Dim list As String
Dim oRange As Range

Set oRange = ActiveDocument.Range
key = InputBox$("Type in the text you want to search for.")
With oRange.Find
.ClearFormatting
.Forward = True
.Format = True
.Text = key
.Wrap = wdFindStop
.Execute

While .Found = True
str = oRange.Sentences(1).Text
'check to see if a sentence is found.
If InStr(1, str, key) > 0 Then
list = list & str & vbCr
End If
.Execute
Wend
End With
MsgBox list
End Sub

If you're still interested, I'll put some thought in finding the Heading 3
preceeding each found word. You Heading 3 doesn't start a new section does it?

Steven Craig Miller

 

[-W]

To: W,

The first part of your task is easy enough:

Sub FindSentenceOfKeyWordOrPhrase()
    Dim key As String
    Dim str As String
    Dim list As String
    Dim oRange As Range

    Set oRange = ActiveDocument.Range
    key = InputBox$("Type in the text you want to search for.")
    With oRange.Find
        .ClearFormatting
        .Forward = True
        .Format = True
        .Text = key
        .Wrap = wdFindStop
        .Execute

        While .Found = True
            str = oRange.Sentences(1).Text
            'check to see if a sentence is found.
            If InStr(1, str, key) > 0 Then
                list = list & str & vbCr
            End If
            .Execute
        Wend
    End With
    MsgBox list
End Sub

If you're still interested, I'll put some thought in finding the Heading 3
preceeding each found word. You Heading 3 doesn't start a new section does it?

Steven Craig Miller

















- Show quoted text -

thank you for this code. I'll try it today

For the headings, they usually don't match up to a section break

Regards
-W

 

[Jean-Guy Marcil]

:

thank you for this code. I'll try it today

For the headings, they usually don't match up to a section break

Try this variation of Steven's code:

_________________________
Option Explicit

Sub FindSentenceOfKeyWord()

Dim strKey As String
Dim rgeDoc As Range
Dim rgeDocEnd As Range
Dim lngOrigin As Long

Set rgeDoc = ActiveDocument.Range
Set rgeDocEnd = ActiveDocument.Range
lngOrigin = rgeDocEnd.End

Do While Trim(strKey) = ""
strKey = InputBox$("Type in the text you want to search for.")
Loop

With rgeDoc.Find
.ClearFormatting
Do While .Execute(FindText:=strKey, Forward:=True, _
Wrap:=wdFindStop)
With rgeDocEnd
.InsertParagraphAfter
.Collapse wdCollapseEnd
End With
rgeDocEnd.FormattedText = .Parent _
.Sentences(1).FormattedText
FindHeading .Parent.Duplicate, rgeDocEnd
If rgeDoc.End >= lngOrigin Then Exit Do
rgeDoc.Start = rgeDoc.End
rgeDoc.End = lngOrigin
Loop
End With

If rgeDocEnd.End = lngOrigin Then
MsgBox "The expression """ & strKey & """ was not found in the " _
& "document.", vbExclamation, "Text not found"
End If

End Sub

Sub FindHeading(ByVal rgeTarget As Range, _
ByRef rgeEnd As Range)

rgeTarget.Collapse wdCollapseStart
rgeTarget.Select
With rgeEnd
.InsertParagraphAfter
.Collapse wdCollapseEnd
End With

With rgeTarget.Find
.ClearFormatting
.Forward = False
.Text = ""
.Style = ActiveDocument.Styles("Heading 3")
If .Execute Then
rgeEnd.FormattedText = .Parent.FormattedText
Exit Sub
Else
rgeEnd.Text = "No instance of ""Heading 3"" " _
& "was found previous to that sentence"
End If

End With

End Sub
___________________________________

Note that you cannot use "Cancel" in the InputBox. This is becasue the
"Cancel" button returns an empty string. But to avoid errors, you also need
to check against empty strings... So the compiler cannot tell if the empty
string is an "empty" InputBox where the user clicked on "OK" or if it is the
result of using the "Cancel" button.

If you want to cancel, just type non-sensical characters in the InputBox
(Such as that they will not be found in the document.)

 

[-W]

Jean-Guy Marcil

You rule! If I ever meet you in person, I owe you a beer. Please
consider this a virtual beer

One last thing to make it perfect

When the code pastes to the bottom of the text it retains the Heading,
and so the automatic number continues. How do you do a Paste Special
such that it keeps the original numbering?

Regards
-W

 

[Jean-Guy Marcil]

Jean-Guy Marcil

You rule! If I ever meet you in person, I owe you a beer. Please
consider this a virtual beer

Thanks, it was refreshing! (Unless it was Yankee beer!)

One last thing to make it perfect

When the code pastes to the bottom of the text it retains the Heading,
and so the automatic number continues. How do you do a Paste Special
such that it keeps the original numbering?

See the ConvertNumbersToText method in the VBA help, pay a special attention
to the example they provide for applying this method to a ListFormat object.