highlight words with apostrophes and insertafter selection

[macrotrain]

With a vba macro, I request assistance from the experts to highlight words with apostrophes from selected text (e.g. I've heard she's at the Jones' house), then list the words found (e.g., I've, she's, Jones') after the selected text. The list is comma delimited and without duplicate words. Any help is appreciated. Thanks.

The vba-word code so far is:

Sub ApostropheHighlight()

'highlight words with apostrophes

'Note: An *at sign* is required before the apostrophe below. Technical difficulties prevent an *at sign* in the post in the following line of code

If (findHL(ActiveDocument.Range, "<[! ]*insert at sign here with no asterisks or spaces*'>")) = True Then MsgBox "Selection words are checked for apostrophes and highlighted, if applicable", vbInformation + vbOKOnly

End Sub

Function findHL(r As Range, s As String) As Boolean
Options.DefaultHighlightColorIndex = wdYellow
r.Find.Replacement.Highlight = True
r.Find.Execute FindText:=s, MatchWildcards:=True, Wrap:=wdFindContinue, Forward:=True, replacewith:="^&", Replace:=wdReplaceAll
findHL = True

'list words with apostrophes, after the selection, comma delimited, no duplicates
'example
'I've, she's, Jones'

r.InsertAfter s & ", "

End Function

[macrotrain]

Post was edited above with instructions for the *at sign*

[macropod]

You could use a macro like:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, StrOut As String
StrOut = " "
Set Rng = Selection.Range
With Selection.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]@['’]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
If .Characters.Last.Next Like "[Ss]" Then .End = .End + 1
If InStr(StrOut, " " & .Text & " ") = 0 Then StrOut = StrOut & .Text & " "
.Collapse wdCollapseEnd
.Find.Execute
Else
Exit Do
End If
Loop
End With
Rng.InsertAfter vbCr & Replace(Trim(StrOut), " ", ", ") & vbCr
Application.ScreenUpdating = True
End Sub

[gmayor]

The problem with detecting apostrophes is that they may be confused with single quotes, especially if the apostrophe is at the end or the beginning of the word. Expanding the original message examples

(I've heard she's at the Jones' house), then list the words found (e.g., I've, she's, Jones') after the selected text. Doesn't it matter. I won't go to the cinema. 'Tis an ill wind'. I can't help it. We've got to go. I'll tell you later.

I don't believe there is a single string that would cover all instances, though it would be easy enough to use separate processes. I don't think it is possible to do so if there are single quotes in the mix (though Paul has a way of winkling out the obscure :)). Take out the single quotes and the following might do the job.


Sub Macro1()
Dim vFindText As Variant
Dim oRng As Range
Dim strList As String
Dim i As Long
strList = vbCr
vFindText = Array("<[A-Za-z]{1,}['’][sn]>", _
"<[A-Za-z]{1,}['’]>", _
"[A-Za-z]{1,}['’][A-Za-z]{1,}>", _
"[!A-Za-z]['’][A-Za-z]{1,}>")
For i = 0 To UBound(vFindText)
Set oRng = Selection.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(FindText:=vFindText(i), _
MatchWildcards:=True, _
Forward:=True, _
Wrap:=wdFindStop) = True
strList = strList & oRng.Text & ", "
oRng.Collapse wdCollapseEnd
Loop
End With
Next
Selection.Range.InsertAfter strList & vbCr
End Sub

[macrotrain]

Paul,

Thank you for the quick response. The macro Sub Demo() above was run for:

*I've heard she's at the Jones' house*

The result:

The macro freezes with the cursor spinning and spinning while stuck at the *End If* statement in yellow, observed via Debug. No listings of words with apostrophes appear. Same result on multiple computers.

Any ideas?

[macrotrain]

Graham,

Thank you for the quick response. The macro Sub Macro1() was run for:

*I've heard she's at the Jones' house*

The result:

Highlight of words with apostrophes is missing. Words with apostrophes are inserted after the selection, with an instance of a duplicate of *she's* listed as the final word (e.g., she's, Jones', I've, she's,). Same result on multiple computers.

Any ideas?

[macropod]

The macro freezes with the cursor spinning and spinning while stuck at the *End If* statement in yellow, observed via Debug.
I don't get that result. Did you actually select the range to process?

The following code revision should return more comprehensive results.

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, StrOut As String
StrOut = " "
Set Rng = Selection.Range
With Selection.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]@['’]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
.End = .Words.Last.End
Do While .Characters.Last.Text Like "[ " & Chr(160) & "]"
.End = .End - 1
Loop
If InStr(StrOut, " " & .Text & " ") = 0 Then StrOut = StrOut & .Text & " "
.Collapse wdCollapseEnd
.Find.Execute
Else
Exit Do
End If
Loop
End With
If Trim(StrOut) <> "" Then Rng.InsertAfter vbCr & Replace(Trim(StrOut), " ", ", ") & vbCr
Application.ScreenUpdating = True
End Sub

[macrotrain]

Paul,

Thank you for checking Sub Demo() v1 and v2. Yes, the range is selected by the mouse cursor for the standalone phrase of *I've heard she's at the Jones' house*. Of note is that the *I've heard she's at the Jones' house* are the only words in the document. The result is the same for both version 1 and version 2. The cursor spins and spins and spins and is stuck at the End If in the Debug. The End If from the macro Debug is in yellow during the stuck phase, but the macro name is not yellowed (i.e., as in if the macro code was in error). Other word documents are also inaccessible while the Sub Demo() is spinning and spinning. Below is excerpted from the Sub Demo code.

Else
Exit Do
'the End If below is highlighted in yellow in the Debug while the macro is stuck while in operation.

End If
Loop

I have no idea why or what the stuck spin at End If is about. A latest attempt had a Microsoft Word stopped working as a result.
Provided there are no other alternatives with Sub Demo(), as an alternative, is it possible to check the Sub Macro1() post? Sub Macro1() was instantaneous, just had one duplicate, with no highlighted words though.

Thanks again.

[macropod]

How are you getting to the position that you can see what is highlighted? If it's by pressing Ctrl-Break, whatever is highlighted just happens to be the part of the code that was executing at the time; it has nothing to do with an error-state in the code.

That aside, the fact you're having trouble with all the macros suggests either:
1. There's some key information about your document configuration you haven't shared; or
2. There's a fault in your Office installation.

To rule out the latter, try repairing the Office installation. This can be done via:
• Programs & Features > Microsoft Office > Change in the Windows Control Panel for Office 2010 & 2013
• Word Options|Resources|Diagnose for Office 2007; or
• Help|Detect & Repair for office 2000 - 2003

[macrotrain]

Paul,
Thank you.
Yes, pressing Ctrl-Break. The macro is run with just the usual statement included, as in previous posts. The macro was just run on another computer with the same result, this time resulting in the cursor spinning eventually in Microsoft Word (Not responding). Other efforts have included a computer at work with the same result. Other macros with selection range work normally.



How are you getting to the position that you can see what is highlighted? If it's by pressing Ctrl-Break, whatever is highlighted just happens to be the part of the code that was executing at the time; it has nothing to do with an error-state in the code.

That aside, the fact you're having trouble with all the macros suggests either:
1. There's some key information about your document configuration you haven't shared; or
2. There's a fault in your Office installation.

To rule out the latter, try repairing the Office installation. This can be done via:
• Programs & Features > Microsoft Office > Change in the Windows Control Panel for Office 2010 & 2013
• Word Options|Resources|Diagnose for Office 2007; or
• Help|Detect & Repair for office 2000 - 2003

[macropod]

As I've already said, the macros I posted both work fine on my system. I've also suggested why they might not work on yours and what you can do about that.

[Tommy]

@Paul
It appears that the .Wrap = wdFindStop is not working like it should.

[Tommy]

As usual I have butchered the crud out of someone else's code that I don't understand. :(
I found that the .Wrap method is asleep on my machine, I am running Office 2013. So the only workaround is check the .End and see if it is set to 0.
Something else I noticed is that the .Find.Found remains True. I tried it with a string that did not have a ', and it still went through the loop.

I am just posting the observations I have had on this issue.


Sub Demo() Application.ScreenUpdating = False
Dim Rng As Range, StrOut As String
StrOut = " "
Set Rng = Selection.Range
With Selection.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]@['’]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
.End = .Words.Last.End
Do While .Characters.Last.Text Like "[ " & Chr(160) & "]"
.End = .End - 1
Loop
If InStr(StrOut, " " & .Text & " ") = 0 Then StrOut = StrOut & .Text & " "
.Collapse wdCollapseEnd
.Find.Execute
If .End = 0 Then
'well now what we have restarted
Exit Do
End If
Else
Exit Do
End If
Loop
End With
If Trim(StrOut) <> "" Then Rng.InsertAfter vbCr & Replace(Trim(StrOut), " ", ", ") & vbCr
Application.ScreenUpdating = True
End Sub