Macro runs only for selected text in the document

[shekhu]

Hi guys,

Can anyone help me out explaining:
Is is possible to run a macro only for selected text in the document containing lot of other text as well? :think:

Thank you for your effort.

[Tinbendr]

only for selected text in the document containing lot of other text as well? Probably, but you'll have to describe it a bit better than this.

[fumei]

Yes, it is a bit hard understanding what you mean exactly.

Do you mean you have a lot of text, and you select just some of it, and you want a macro to do somethingwith just that selected text?

If so, then it is very easy, just use Selection.Text.

[shekhu]

Gerry and Tinbendr

I would like the following two macros just run for the text that has been selected in a document, and the rest of the text that has not been selected doesn't get affected.

Secondly, for an instance is it possible that instead of wdReplaceAll we do wdReplaceOne, that replaces only the first occurrence and leave the rest in the selected portion (this will be a similar separate macro).

Sub Array_Drug_Generic_Macro()
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array(" Alprazolam ", " Amlodipine ", _
" Alprazolam,", " Amlodipine," _
" Alprazolam.", " Amlodipine.")
ReplaceArray = Array(" alprazolam ", " amlodipine ", _
" alprazolam,", " amlodipine,", _
" alprazolam.", " amlodipine.")
Set myRange = ActiveDocument.Range
For i = LBound(SearchArray) To UBound(SearchArray)
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
.Replacement.Text = pReplace
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub




Sub AF6()
AF666 True, True, True
End Sub

Sub AF666(ByRef bBold As Boolean, bTab As Boolean, bPar As Boolean)
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array(" heading ", " paragraph ")
ReplaceArray = Array(" HEADING: ", " PARAGRAPH: ")
Set myRange = ActiveDocument.Range
For i = LBound(SearchArray) To UBound(SearchArray)
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
Select Case True
Case bTab And bPar
If i = 0 Then
.Replacement.Text = pReplace & vbTab
Else
.Replacement.Text = vbCr & pReplace & vbTab
End If
Case Not bTab And bPar
If i = 0 Then
.Replacement.Text = pReplace & " "
Else
.Replacement.Text = vbCr & pReplace & " "
End If
Case bTab And Not bPar
.Replacement.Text = pReplace & vbTab
End Select
If bBold Then
.Replacement.Font.Bold = True
Else
.Replacement.Font.Bold = False
End If
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub

[shekhu]

Gerry

I tried to use Selection.Text but could not make the macro run.

Please elaborate the change that is to be made in the macro.

Sunil

[macropod]

hi Sunil,

Try changing:
Set myRange = ActiveDocument.Range
to:
Set myRange = Selection.Range
in both subs.

Also, unless you really need the characters before & after the found words highlighted, your array contents seem overkill - you should be able to use just:

SearchArray = Array("Alprazolam", "Amlodipine")
ReplaceArray = Array("alprazolam", "amlodipine")
and, even if you do want to include the characters before & after, you could probably use just the above array definitions along with:


With myRange.Find
.Text = "(?)" & pFind & "(?)"
.Replacement.Text = "\1" & pReplace & "\2"
.MatchWildcards = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With

[shekhu]

Thanks macropod, this works now, its great. :clap: :bow: :friends:


Secondly, for an instance is it possible that instead of wdReplaceAll we do wdReplaceOne, that replaces only the first occurrence and leave the rest in the selected portion (this will be a similar separate macro).
Could you please also look at the second part of my request. This is a perfectly similar macro, the only difference is that I want this to replace only the first occurrence and leave the rest in the document.

Also of note, I would intend to run both the macros by clubbing it using the following:
Application.Run MacroName:="macro name"

[macropod]

Hi Sunil,

Change:
.Execute Replace:=wdReplaceAll
to
.Execute Replace:=wdReplaceOne

To run both macros as a single command, you could call them from another sub like:
Sub DoIt()
Call Array_Drug_Generic_Macro
Call AF666 True, True, True
End Sub
With this approach, you could delete your 'AF6' macro.

An alternative approach would be to simply add the line:
Call AF666 True, True, True
to the end of the 'Array_Drug_Generic_Macro' macro.

[shekhu]

Hi macropod,

The problem still persists and that is with the RepOne. Here it replaces only the first occurrence of "impression" and not for "history" or the "plan". Please suggest.

Sub DoIt()
Call RepAll
RepOne True, True, True
End Sub


Sub RepAll()
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "acetazolamide", "AcipHex", "Actonel", "Actos")
Set myRange = Selection.Range
For i = LBound(SearchArray) To UBound(SearchArray)
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
.Replacement.Text = pReplace
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = True
End With
Next
End Sub


Sub RepOne(ByRef bBold As Boolean, bTab As Boolean, bPar As Boolean)
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array("impression", "history", "plan")
ReplaceArray = Array("IMPRESSION:", "HISTORY:", "PLAN:")
Set myRange = Selection.Range
For i = LBound(SearchArray) To UBound(SearchArray)
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
Select Case True
Case bTab And bPar
If i = 0 Then
.Replacement.Text = pReplace & vbTab
Else
.Replacement.Text = vbCr & pReplace & vbTab
End If
Case Not bTab And bPar
If i = 0 Then
.Replacement.Text = pReplace & " "
Else
.Replacement.Text = vbCr & pReplace & " "
End If
Case bTab And Not bPar
.Replacement.Text = pReplace & vbTab
End Select
If bBold Then
.Replacement.Font.Bold = True
Else
.Replacement.Font.Bold = False
End If
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceOne
End With
Next
End Sub

[macropod]

Hi Sunil,

Your RepOne macro takes two find parameters. Unless the search strings match the case conditions you have defined for those parameters, they will no be processed. Your case parameters do not test for all possible combinations - you have no:
Case Not bTab And Not bPar

Further, you have two tests:
If i = 0 Then
that specifically exclude "history" and "plan" from processing for:
Case bTab And bPar
and:
Case Not bTab And bPar

Without knowing how your document is formatted and how many instances of "history" and "plan" there are, or what exactly you're expecting to see, it is impossible to say why you might not be getting the expected results.

[shekhu]

Macropod, To make it clear, in RepAll, it searches for all the occurrences and replaces all of them, no matter how many times that word appears in the document. On the other hand RepOne, only replaces the first time the word appears, and ignores that word if it appears again. There is no fix possibility the word would appear, it can be none, one, or any number of times.

As to the document formatting, I dont understand what further information you need? Please specify.

Secondly, in addition to the above could you please suggest me where should I insert the code to get a message box to the first macro (RepAll). It would be great.
Eg.
Ans$ = MsgBox(oRng & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format")

[macropod]

Hi Sunil,

As to the document formatting, I dont understand what further information you need? Please specify.Sorry, you can disregard that. I believe you can solve the problem by changing:
With myRange.Find
to:
With myRange.Duplicate.Find


where should I insert the code to get a message box to the first macro (RepAll).Ans$ = MsgBox(oRng & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format")That depends on exactly what it is you want to do. Unless you only want to find out whether the code should automatically replace every instance of each word from the array, that's really not viable without a major re-write of the code. Asking for each instance of each found word from the array requires significantly differrent code.

[shekhu]

Hi Macropod,
I got the following suggestion from a different forum. The little problem it has is that it searches whole of the document (thus gives messages for all the finds in the document) and not the selected portion (text) in the document only.

Although, it replaces only in the selected portion, and ignores the rest (this part is okay).

Sub RepAll()
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim i As Long
Dim pFind As String
Dim pReplace As String

SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "acetazolamide", "AcipHex", "Actonel", "Actos")
Set myRange = Selection.Range
For i = LBound(SearchArray) To UBound(SearchArray)
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
.Replacement.Text = pReplace
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = True
End With
End If
Next
End Sub

[macropod]

Hi Sunil,

I got the following suggestion from a different forum.
For cross-posting etiquette, please read:
http://www.excelguru.ca/node/7
And post a link to your thread(s) in the other forum(s) in the corresponding threads in this forum.

Regarding:

The little problem it has is that it searches whole of the document (thus gives messages for all the finds in the document) and not the selected portion (text) in the document only
I can't see how that is possible - and it doesn't do so in my testing. The code asks once for each expression in the array and, if you answer 'yes', processes all matches in the selection without further user intervention.

PS: The way your code is written, it won't highlight the first item from the array to which you give the 'yes' response. If you want to highlight all items you need to swap these two lines around:
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = True

[shekhu]

I am sorry, I was not aware of that issue. Anyway the link to the above code is:
http://www.codeguru.com/forum/showthread.php?t=505746

[shekhu]

If you want to highlight all items you need to swap these two lines around:
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = True

Thats okay with me, please go ahead.

[macropod]

If you want to highlight all items you need to swap these two lines around:
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = TrueThats okay with me, please go ahead.
Hi Sunil,

That means you need to make the change, that is, change:


.Execute Replace:=wdReplaceAll
.Replacement.Highlight = True
to:

.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll

Please also post a link to this thread at codeguru.com - the folks there should know what advice you sought and received here too!

[shekhu]

macropod, thats not happening. It was better earlier, i.e., #13.
What I need is macro only asks for Yes/No for the found words in the selected portion only that means if two words are found then two times only, and ignores the rest (I will have to click 10 times on Yes/No for all the words, if i feed 10 words here even if they are not in the selected portion, this does not sound good).

Likewise replace in the selected portion only (this part is fine here.)

As to the following, this doesnt help.
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = True

[macropod]

Hi Sunil,


macropod, thats not happening. It was better earlier, i.e., #13.
What I need is macro only asks for Yes/No for the found words in the selected portion only that means if two words are found then two times only, and ignores the rest (I will have to click 10 times on Yes/No for all the words, if i feed 10 words here even if they are not in the selected portion, this does not sound good).
In your post #13, you said:

I got the following suggestion from a different forum. The little problem it has is that it searches whole of the document (thus gives messages for all the finds in the document) and not the selected portion (text) in the document only.That simply isn't true - at least not for the macro in your post #13.

I suspect that the reason you're having problems now is that, with the cross-posting and changes to the problem description, you've confused which advice applies to what. The RepAll macro is #13 only processes the text in the selection. If there is more than one occurrence, all occurrences get replaced and, if you don't select anything, every occurrence in the document gets replaced. That's how it is supposed to work. If you wanted it to only replace the first occurrence of each word, you'd have to change:
.Execute Replace:=wdReplaceAll
to:
.Execute Replace:=wdReplaceOne
but then the macro would no longer be a 'RepAll'!

[shekhu]

I think we are not getting each other right. The following macro is okay with me to whatever it does. I have incorporated your suggestions as well.
What further I need in this is the following:
This macro contains 5 words. If I select a text in a document that contains actonel once and aciphex twice. If I run this macro I have to click on Yes/No 5 times. Ideally what should be is the message should pop up only thrice, once for actonel and twice for aciphex; and for the rest of the words that are not searched ,i.e., abilify, acetazolamide, and actos it should ignore popping up.

I hope I am clear this time. Sorry for any misunderstanding on my part.
Sunil

Sub RepAllWithMessage()
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "acetazolamide", "AcipHex", "Actonel", "Actos")
Set myRange = Selection.Range
For i = LBound(SearchArray) To UBound(SearchArray)
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
.Replacement.Text = pReplace
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
End If
Next
End Sub

[macropod]

Hi Sunil,

Try:
Sub RepAllWithMessage1()
Dim oRng As Range, fRng As Range, i As Integer
Dim SearchArray As Variant, ReplaceArray As Variant
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "acetazolamide", "AcipHex", "Actonel", "Actos")
With Selection
Set oRng = .Range
With .Find
.ClearFormatting
.MatchCase = True
.Highlight = False
.MatchWildcards = False
.Wrap = wdFindContinue
.Forward = True
For i = 0 To UBound(SearchArray)
.Text = SearchArray(i)
Do While .Execute = True
If Selection.Start > oRng.End Then Exit Do
Set fRng = ActiveDocument.Range(Start:=Selection.Start, End:=Selection.End)
With fRng
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
.Text = ReplaceArray(i)
.HighlightColorIndex = wdYellow
.Collapse Direction:=wdCollapseEnd
End If
End With
Loop
oRng.Select
Next
End With
End With
oRng.Select
Set fRng = Nothing: Set oRng = Nothing
End Sub

[gmaxey]

Well you are still not clear as to what your expectations are :-(

If you want the code to "ReplaceAll" then the prompt should only appear twice (once for each word) not thrice (once for each instance of each word). What are you really trying to achieve?

Consider the following:

Sub RepOneWithMessage()
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim oRngSrch As Word.Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "Acetazolamide", "AcipHex", "Actonel", "Actos")
For i = LBound(SearchArray) To UBound(SearchArray)
Set oRngSrch = Selection.Range
Set myRange = Selection.Range
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
.MatchWholeWord = True
.Replacement.Highlight = True
While .Execute
If myRange.InRange(oRngSrch) Then
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
myRange.Text = pReplace
myRange.Collapse wdCollapseEnd
End If
End If
Wend
End With
Next
End Sub

Sub RepAllWithMessage()
Dim SearchArray As Variant
Dim ReplaceArray As Variant
Dim myRange As Range
Dim oRngSrch As Word.Range
Dim i As Long
Dim pFind As String
Dim pReplace As String
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "Acetazolamide", "AcipHex", "Actonel", "Actos")
For i = LBound(SearchArray) To UBound(SearchArray)
Set oRngSrch = Selection.Range
Set myRange = Selection.Range
pFind = SearchArray(i)
pReplace = ReplaceArray(i)
With myRange.Find
.Text = pFind
.MatchWholeWord = True
Do While .Execute
If myRange.InRange(oRngSrch) Then
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
Set myRange = Selection.Range
With myRange.Find
.Text = pFind
.Replacement.Text = pReplace
.Execute Replace:=wdReplaceAll
End With
End If
Exit Do
Else
Exit Do
End If
Loop
End With
Next
End Sub

[macropod]

Hi Greg,

Your 'RepOneWithMessage' macro doesn't actually apply the highlighting (I haven't checked the other one yet). That's because a 'Replace' action isn't occurring. Try:
Sub RepOneWithMessage()
Dim SearchArray As Variant, ReplaceArray As Variant
Dim myRange As Range, oRngSrch As Range, i As Long
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "Acetazolamide", "AcipHex", "Actonel", "Actos")
Set oRngSrch = Selection.Range
For i = LBound(SearchArray) To UBound(SearchArray)
Set myRange = oRngSrch.Duplicate
With myRange.Find
.Text = SearchArray(i)
.MatchWholeWord = True
While .Execute
With myRange
If .InRange(oRngSrch) Then
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
.HighlightColorIndex = wdYellow
.Text = ReplaceArray(i)
.Collapse wdCollapseEnd
End If
End If
End With
Wend
End With
Next
End Sub

[shekhu]

PERFECT :thumb

Thanks Paul and Greg for your effort and time, its really great being here.

Greg, as Paul pointed out there was issue with .Replacement.Highlight = True Anyways I was able to overcome it.

Initially, I was confused as to RepAll and RepOne, now got the point, but both the macros are useful to me depending on the situation where I use each one of them. The code at #21 is specifying the word that is being replaced and selecting that before changing and highlighting, thats great.
It's like a double bonanza for me today.
Thanks again guys, will be back if any further issues crop up.

[gmaxey]

Paul,

Thanks. You caught me being sloppy :(


Hi Greg,

Your 'RepOneWithMessage' macro doesn't actually apply the highlighting (I haven't checked the other one yet). That's because a 'Replace' action isn't occurring. Try:
Sub RepOneWithMessage()
Dim SearchArray As Variant, ReplaceArray As Variant
Dim myRange As Range, oRngSrch As Range, i As Long
SearchArray = Array("abilify", "acetazolamide", "aciphex", "actonel", "actos")
ReplaceArray = Array("Abilify", "Acetazolamide", "AcipHex", "Actonel", "Actos")
Set oRngSrch = Selection.Range
For i = LBound(SearchArray) To UBound(SearchArray)
Set myRange = oRngSrch.Duplicate
With myRange.Find
.Text = SearchArray(i)
.MatchWholeWord = True
While .Execute
With myRange
If .InRange(oRngSrch) Then
If MsgBox(SearchArray(i) & vbCr & vbCr & "Change this one?", vbYesNo, "Change Format") = vbYes Then
.HighlightColorIndex = wdYellow
.Text = ReplaceArray(i)
.Collapse wdCollapseEnd
End If
End If
End With
Wend
End With
Next
End Sub