Find Acromyns in the document

[Designingsally]

Hi ppl there

I got a code which highlights all the abbreviation present in a document.
But i want the code to be tweeked a bit. I want the macro to:
1. Highlight the abbreviation one by one.
2. After one abbreviation is highlighted a message box must be displayed.
3. The message shd be add THE before the abbreviation. It must have 2 button
REPLACE and DECLINE.
4. If the user clicks REPLACE "THE" must be added before the abbreviation.
If the user clicks DECLINE. The macro shd highlight UK in the document.
5. Step 3

Thanks for the help . I m a novice. I ll be glad if someone helps me with
this.


The code I got is this:


For example:

UN is not in UK.

The macro shd highlight UN.
A msg box must appear asking to add THE before UN. If the user clicks
REPLACE then THE must be added automatically.
After this action, the macro highlights UN. The
Public Sub subCountAcronyms()

Dim olWholeStory As Range
Dim slAcronym As String
Dim dbllT As Double
Dim rlWord As Range
Dim llWordCount As Long
Dim ilAcronymCount As Integer
Dim ilChr1 As Integer
Dim ilChr2 As Integer
Dim ilStyleAcronymCount As Integer
Dim rlStyle As Style
Dim rlStyles As Styles
Dim slNormalStyle As String

Application.DisplayStatusBar = True
dbllT = Timer
Set olWholeStory = Selection.Range
olWholeStory.WholeStory

slNormalStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal).NameLocal
llWordCount = 0
ilAcronymCount = 0
ilStyleAcronymCount = 0

' Go through the Doc word by word.
For Each rlWord In olWholeStory.Words
StatusBar = rlWord.Text
llWordCount = llWordCount + 1
If Len(rlWord) > 1 Then

ilChr2 = Asc(Mid$(rlWord.Text, 2, 1))
Select Case ilChr2
Case Is < 65, Is > 90
' 2nd Chr Not upper case.
Case Else
' 2nd Chr is upper case.

ilChr1 = Asc(Mid$(rlWord.Text, 1, 1))
Select Case ilChr1
Case Is < 65, Is > 90
' 1st Chr Not upper case.
Case Else
' 1st Chr is upper case.

' Is the word in "normal" style?
If rlWord.Style <> slNormalStyle Then
ilStyleAcronymCount = ilStyleAcronymCount + 1
rlWord.HighlightColorIndex = wdBrightGreen
Else
rlWord.HighlightColorIndex = wdPink
End If

' Do something with the acronym.
subWriteAcronym rlWord.Text
MsgBox (" Replace it with THE"), 76
ilAcronymCount = ilAcronymCount + 1
End Select
End Select
End If
Next rlWord

StatusBar = Round((Timer - dbllT), 1) _
& "secs " & llWordCount & " Words " _
& ilAcronymCount & " Acronyms " _
& ilStyleAcronymCount & " Acronyms not in Normal Styale "
End Sub
Public Sub subWriteAcronym(spAcronym As String)
'MsgBox spAcronym

 

[Pesach Shelnitz]

Hi Sally,

Try this macro and see if it does what you want.

Sub TheBeforeAcronym()
Dim myRange As Range
Dim rslt As VbMsgBoxResult

Set myRange = ActiveDocument.Range
With myRange
.Start = 0
Do While .Find.Execute(FindText:="<([A-Z]{2,})>", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
myRange.Select
rslt = MsgBox(Prompt:="Add 'the' before this acronym?", _
Buttons:=vbYesNo)
If rslt = vbYes Then
Selection.InsertBefore "the "
.Collapse Direction:=wdCollapseEnd
End If
.Collapse Direction:=wdCollapseEnd
Loop
Selection.Collapse Direction:=wdCollapseEnd
End With
Set myRange = Nothing
End Sub

 

[Designingsally]

Hi Pesach Shelnitz

It worked fantastically.

Thanks a ton.
--
I believe in Hope.

DesigningSally

Hi Sally,

Try this macro and see if it does what you want.

Sub TheBeforeAcronym()
Dim myRange As Range
Dim rslt As VbMsgBoxResult

Set myRange = ActiveDocument.Range
With myRange
.Start = 0
Do While .Find.Execute(FindText:="<([A-Z]{2,})>", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
myRange.Select
rslt = MsgBox(Prompt:="Add 'the' before this acronym?", _
Buttons:=vbYesNo)
If rslt = vbYes Then
Selection.InsertBefore "the "
.Collapse Direction:=wdCollapseEnd
End If
.Collapse Direction:=wdCollapseEnd
Loop
Selection.Collapse Direction:=wdCollapseEnd
End With
Set myRange = Nothing
End Sub

--
Hope this helps,
Pesach Shelnitz

Hi ppl there

I got a code which highlights all the abbreviation present in a document.
But i want the code to be tweeked a bit. I want the macro to:
1. Highlight the abbreviation one by one.
2. After one abbreviation is highlighted a message box must be displayed.
3. The message shd be add THE before the abbreviation. It must have 2 button
REPLACE and DECLINE.
4. If the user clicks REPLACE "THE" must be added before the abbreviation.
If the user clicks DECLINE. The macro shd highlight UK in the document.
5. Step 3

Thanks for the help . I m a novice. I ll be glad if someone helps me with
this.


The code I got is this:


For example:

UN is not in UK.

The macro shd highlight UN.
A msg box must appear asking to add THE before UN. If the user clicks
REPLACE then THE must be added automatically.
After this action, the macro highlights UN. The
Public Sub subCountAcronyms()

Dim olWholeStory As Range
Dim slAcronym As String
Dim dbllT As Double
Dim rlWord As Range
Dim llWordCount As Long
Dim ilAcronymCount As Integer
Dim ilChr1 As Integer
Dim ilChr2 As Integer
Dim ilStyleAcronymCount As Integer
Dim rlStyle As Style
Dim rlStyles As Styles
Dim slNormalStyle As String

Application.DisplayStatusBar = True
dbllT = Timer
Set olWholeStory = Selection.Range
olWholeStory.WholeStory

slNormalStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal).NameLocal
llWordCount = 0
ilAcronymCount = 0
ilStyleAcronymCount = 0

' Go through the Doc word by word.
For Each rlWord In olWholeStory.Words
StatusBar = rlWord.Text
llWordCount = llWordCount + 1
If Len(rlWord) > 1 Then

ilChr2 = Asc(Mid$(rlWord.Text, 2, 1))
Select Case ilChr2
Case Is < 65, Is > 90
' 2nd Chr Not upper case.
Case Else
' 2nd Chr is upper case.

ilChr1 = Asc(Mid$(rlWord.Text, 1, 1))
Select Case ilChr1
Case Is < 65, Is > 90
' 1st Chr Not upper case.
Case Else
' 1st Chr is upper case.

' Is the word in "normal" style?
If rlWord.Style <> slNormalStyle Then
ilStyleAcronymCount = ilStyleAcronymCount + 1
rlWord.HighlightColorIndex = wdBrightGreen
Else
rlWord.HighlightColorIndex = wdPink
End If

' Do something with the acronym.
subWriteAcronym rlWord.Text
MsgBox (" Replace it with THE"), 76
ilAcronymCount = ilAcronymCount + 1
End Select
End Select
End If
Next rlWord

StatusBar = Round((Timer - dbllT), 1) _
& "secs " & llWordCount & " Words " _
& ilAcronymCount & " Acronyms " _
& ilStyleAcronymCount & " Acronyms not in Normal Styale "
End Sub
Public Sub subWriteAcronym(spAcronym As String)
'MsgBox spAcronym

 

[Designingsally]

Hi Pesach

thanks for the reply. It did help me. But as I started to demonstrate ur
code under different suitation i found that when macros even though THE
exists before abbreviation it continues to ask if THE should be added before
the acromyn. I dont want that to happen. Cos it does NOT make sense if macros
continue to highlight acrynmn when THE is already placed before that.

Can you help me out with the solution? Thanks in advance.
Code i tired is as below:

Sub TheBeforeAcronym()
Dim myRange As Range
Dim rslt As VbMsgBoxResult

Set myRange = ActiveDocument.Range
With myRange
.Start = 0
Do While .Find.Execute(FindText:="<([A-Z]{2,})>", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
myRange.Select
rslt = Msgbox(Prompt:="Add 'the' before this acronym?", _
Buttons:=vbYesNoCancel)
If rslt = vbCancel Then
Exit Sub
End If
If rslt = vbYes Then
Selection.InsertBefore "the "
.Collapse Direction:=wdCollapseEnd
End If
.Collapse Direction:=wdCollapseEnd
Loop
Selection.Collapse Direction:=wdCollapseEnd


End With
Set myRange = Nothing
End Sub



--
I believe in Hope.

DesigningSally

Hi Sally,

Try this macro and see if it does what you want.

Sub TheBeforeAcronym()
Dim myRange As Range
Dim rslt As VbMsgBoxResult

Set myRange = ActiveDocument.Range
With myRange
.Start = 0
Do While .Find.Execute(FindText:="<([A-Z]{2,})>", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
myRange.Select
rslt = MsgBox(Prompt:="Add 'the' before this acronym?", _
Buttons:=vbYesNo)
If rslt = vbYes Then
Selection.InsertBefore "the "
.Collapse Direction:=wdCollapseEnd
End If
.Collapse Direction:=wdCollapseEnd
Loop
Selection.Collapse Direction:=wdCollapseEnd
End With
Set myRange = Nothing
End Sub

--
Hope this helps,
Pesach Shelnitz

Hi ppl there

I got a code which highlights all the abbreviation present in a document.
But i want the code to be tweeked a bit. I want the macro to:
1. Highlight the abbreviation one by one.
2. After one abbreviation is highlighted a message box must be displayed.
3. The message shd be add THE before the abbreviation. It must have 2 button
REPLACE and DECLINE.
4. If the user clicks REPLACE "THE" must be added before the abbreviation.
If the user clicks DECLINE. The macro shd highlight UK in the document.
5. Step 3

Thanks for the help . I m a novice. I ll be glad if someone helps me with
this.


The code I got is this:


For example:

UN is not in UK.

The macro shd highlight UN.
A msg box must appear asking to add THE before UN. If the user clicks
REPLACE then THE must be added automatically.
After this action, the macro highlights UN. The
Public Sub subCountAcronyms()

Dim olWholeStory As Range
Dim slAcronym As String
Dim dbllT As Double
Dim rlWord As Range
Dim llWordCount As Long
Dim ilAcronymCount As Integer
Dim ilChr1 As Integer
Dim ilChr2 As Integer
Dim ilStyleAcronymCount As Integer
Dim rlStyle As Style
Dim rlStyles As Styles
Dim slNormalStyle As String

Application.DisplayStatusBar = True
dbllT = Timer
Set olWholeStory = Selection.Range
olWholeStory.WholeStory

slNormalStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal).NameLocal
llWordCount = 0
ilAcronymCount = 0
ilStyleAcronymCount = 0

' Go through the Doc word by word.
For Each rlWord In olWholeStory.Words
StatusBar = rlWord.Text
llWordCount = llWordCount + 1
If Len(rlWord) > 1 Then

ilChr2 = Asc(Mid$(rlWord.Text, 2, 1))
Select Case ilChr2
Case Is < 65, Is > 90
' 2nd Chr Not upper case.
Case Else
' 2nd Chr is upper case.

ilChr1 = Asc(Mid$(rlWord.Text, 1, 1))
Select Case ilChr1
Case Is < 65, Is > 90
' 1st Chr Not upper case.
Case Else
' 1st Chr is upper case.

' Is the word in "normal" style?
If rlWord.Style <> slNormalStyle Then
ilStyleAcronymCount = ilStyleAcronymCount + 1
rlWord.HighlightColorIndex = wdBrightGreen
Else
rlWord.HighlightColorIndex = wdPink
End If

' Do something with the acronym.
subWriteAcronym rlWord.Text
MsgBox (" Replace it with THE"), 76
ilAcronymCount = ilAcronymCount + 1
End Select
End Select
End If
Next rlWord

StatusBar = Round((Timer - dbllT), 1) _
& "secs " & llWordCount & " Words " _
& ilAcronymCount & " Acronyms " _
& ilStyleAcronymCount & " Acronyms not in Normal Styale "
End Sub
Public Sub subWriteAcronym(spAcronym As String)
'MsgBox spAcronym

 

[Designingsally]

Hi
i want the macros to skip inserting THE before TABLE. is it possible?
Thanks in advance

Sally

if the macros were to search this sample data
UNO
ROCK
ROLLING
TABLE
ROLL
RAMS

Code is
Sub TheBeforeAcronym()
Dim myRange As Range
Dim orng As Range
Dim rslt As VbMsgBoxResult
Set myRange = ActiveDocument.Range
With myRange.FInd
..Text = "<([A-Z]{3,})>"
..MatchWildcards = True
..Wrap = wdFindStop
..Forward = True
While .Execute
myRange.Select
Set orng = myRange.Duplicate
orng.Move wdCharacter, -5
orng.MoveEnd wdCharacter, 4
If Not orng.Text = "the " Then
rslt = Msgbox(Prompt:="Add 'the' before this acronym?",
Buttons:=vbYesNoCancel)
If rslt = vbCancel Then Exit Sub
If rslt = vbYes Then
Selection.InsertBefore "the "
myRange.Collapse wdCollapseEnd
End If
End If
myRange.Collapse wdCollapseEnd
Wend
End With
Set myRange = Nothing
End Sub
--
I believe in Hope.

DesigningSally

Hi Sally,

Try this macro and see if it does what you want.

Sub TheBeforeAcronym()
Dim myRange As Range
Dim rslt As VbMsgBoxResult

Set myRange = ActiveDocument.Range
With myRange
.Start = 0
Do While .Find.Execute(FindText:="<([A-Z]{2,})>", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
myRange.Select
rslt = MsgBox(Prompt:="Add 'the' before this acronym?", _
Buttons:=vbYesNo)
If rslt = vbYes Then
Selection.InsertBefore "the "
.Collapse Direction:=wdCollapseEnd
End If
.Collapse Direction:=wdCollapseEnd
Loop
Selection.Collapse Direction:=wdCollapseEnd
End With
Set myRange = Nothing
End Sub

--
Hope this helps,
Pesach Shelnitz

Hi ppl there

I got a code which highlights all the abbreviation present in a document.
But i want the code to be tweeked a bit. I want the macro to:
1. Highlight the abbreviation one by one.
2. After one abbreviation is highlighted a message box must be displayed.
3. The message shd be add THE before the abbreviation. It must have 2 button
REPLACE and DECLINE.
4. If the user clicks REPLACE "THE" must be added before the abbreviation.
If the user clicks DECLINE. The macro shd highlight UK in the document.
5. Step 3

Thanks for the help . I m a novice. I ll be glad if someone helps me with
this.


The code I got is this:


For example:

UN is not in UK.

The macro shd highlight UN.
A msg box must appear asking to add THE before UN. If the user clicks
REPLACE then THE must be added automatically.
After this action, the macro highlights UN. The
Public Sub subCountAcronyms()

Dim olWholeStory As Range
Dim slAcronym As String
Dim dbllT As Double
Dim rlWord As Range
Dim llWordCount As Long
Dim ilAcronymCount As Integer
Dim ilChr1 As Integer
Dim ilChr2 As Integer
Dim ilStyleAcronymCount As Integer
Dim rlStyle As Style
Dim rlStyles As Styles
Dim slNormalStyle As String

Application.DisplayStatusBar = True
dbllT = Timer
Set olWholeStory = Selection.Range
olWholeStory.WholeStory

slNormalStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal).NameLocal
llWordCount = 0
ilAcronymCount = 0
ilStyleAcronymCount = 0

' Go through the Doc word by word.
For Each rlWord In olWholeStory.Words
StatusBar = rlWord.Text
llWordCount = llWordCount + 1
If Len(rlWord) > 1 Then

ilChr2 = Asc(Mid$(rlWord.Text, 2, 1))
Select Case ilChr2
Case Is < 65, Is > 90
' 2nd Chr Not upper case.
Case Else
' 2nd Chr is upper case.

ilChr1 = Asc(Mid$(rlWord.Text, 1, 1))
Select Case ilChr1
Case Is < 65, Is > 90
' 1st Chr Not upper case.
Case Else
' 1st Chr is upper case.

' Is the word in "normal" style?
If rlWord.Style <> slNormalStyle Then
ilStyleAcronymCount = ilStyleAcronymCount + 1
rlWord.HighlightColorIndex = wdBrightGreen
Else
rlWord.HighlightColorIndex = wdPink
End If

' Do something with the acronym.
subWriteAcronym rlWord.Text
MsgBox (" Replace it with THE"), 76
ilAcronymCount = ilAcronymCount + 1
End Select
End Select
End If
Next rlWord

StatusBar = Round((Timer - dbllT), 1) _
& "secs " & llWordCount & " Words " _
& ilAcronymCount & " Acronyms " _
& ilStyleAcronymCount & " Acronyms not in Normal Styale "
End Sub
Public Sub subWriteAcronym(spAcronym As String)
'MsgBox spAcronym

 

[Graham Mayor]

See your later duplicate post!

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

Hi
i want the macros to skip inserting THE before TABLE. is it possible?
Thanks in advance

Sally

if the macros were to search this sample data
UNO
ROCK
ROLLING
TABLE
ROLL
RAMS

Code is
Sub TheBeforeAcronym()
Dim myRange As Range
Dim orng As Range
Dim rslt As VbMsgBoxResult
Set myRange = ActiveDocument.Range
With myRange.FInd
.Text = "<([A-Z]{3,})>"
.MatchWildcards = True
.Wrap = wdFindStop
.Forward = True
While .Execute
myRange.Select
Set orng = myRange.Duplicate
orng.Move wdCharacter, -5
orng.MoveEnd wdCharacter, 4
If Not orng.Text = "the " Then
rslt = Msgbox(Prompt:="Add 'the' before this acronym?",
Buttons:=vbYesNoCancel)
If rslt = vbCancel Then Exit Sub
If rslt = vbYes Then
Selection.InsertBefore "the "
myRange.Collapse wdCollapseEnd
End If
End If
myRange.Collapse wdCollapseEnd
Wend
End With
Set myRange = Nothing
End Sub

Hi Sally,

Try this macro and see if it does what you want.

Sub TheBeforeAcronym()
Dim myRange As Range
Dim rslt As VbMsgBoxResult

Set myRange = ActiveDocument.Range
With myRange
.Start = 0
Do While .Find.Execute(FindText:="<([A-Z]{2,})>", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
myRange.Select
rslt = MsgBox(Prompt:="Add 'the' before this acronym?", _
Buttons:=vbYesNo)
If rslt = vbYes Then
Selection.InsertBefore "the "
.Collapse Direction:=wdCollapseEnd
End If
.Collapse Direction:=wdCollapseEnd
Loop
Selection.Collapse Direction:=wdCollapseEnd
End With
Set myRange = Nothing
End Sub

--
Hope this helps,
Pesach Shelnitz

Hi ppl there

I got a code which highlights all the abbreviation present in a
document. But i want the code to be tweeked a bit. I want the macro
to:
1. Highlight the abbreviation one by one.
2. After one abbreviation is highlighted a message box must be
displayed.
3. The message shd be add THE before the abbreviation. It must have
2 button REPLACE and DECLINE.
4. If the user clicks REPLACE "THE" must be added before the
abbreviation. If the user clicks DECLINE. The macro shd highlight
UK in the document.
5. Step 3

Thanks for the help . I m a novice. I ll be glad if someone helps
me with this.


The code I got is this:


For example:

UN is not in UK.

The macro shd highlight UN.
A msg box must appear asking to add THE before UN. If the user
clicks REPLACE then THE must be added automatically.
After this action, the macro highlights UN. The
Public Sub subCountAcronyms()

Dim olWholeStory As Range
Dim slAcronym As String
Dim dbllT As Double
Dim rlWord As Range
Dim llWordCount As Long
Dim ilAcronymCount As Integer
Dim ilChr1 As Integer
Dim ilChr2 As Integer
Dim ilStyleAcronymCount As Integer
Dim rlStyle As Style
Dim rlStyles As Styles
Dim slNormalStyle As String

Application.DisplayStatusBar = True
dbllT = Timer
Set olWholeStory = Selection.Range
olWholeStory.WholeStory

slNormalStyle =
ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal).NameLocal
llWordCount = 0
ilAcronymCount = 0
ilStyleAcronymCount = 0

' Go through the Doc word by word.
For Each rlWord In olWholeStory.Words
StatusBar = rlWord.Text
llWordCount = llWordCount + 1
If Len(rlWord) > 1 Then

ilChr2 = Asc(Mid$(rlWord.Text, 2, 1))
Select Case ilChr2
Case Is < 65, Is > 90
' 2nd Chr Not upper case.
Case Else
' 2nd Chr is upper case.

ilChr1 = Asc(Mid$(rlWord.Text, 1, 1))
Select Case ilChr1
Case Is < 65, Is > 90
' 1st Chr Not upper case.
Case Else
' 1st Chr is upper case.

' Is the word in "normal" style?
If rlWord.Style <> slNormalStyle Then
ilStyleAcronymCount = ilStyleAcronymCount + 1
rlWord.HighlightColorIndex = wdBrightGreen
Else
rlWord.HighlightColorIndex = wdPink
End If

' Do something with the acronym.
subWriteAcronym rlWord.Text
MsgBox (" Replace it with THE"), 76
ilAcronymCount = ilAcronymCount + 1
End Select
End Select
End If
Next rlWord

StatusBar = Round((Timer - dbllT), 1) _
& "secs " & llWordCount & " Words " _
& ilAcronymCount & " Acronyms " _
& ilStyleAcronymCount & " Acronyms not in Normal Styale "
End Sub
Public Sub subWriteAcronym(spAcronym As String)
'MsgBox spAcronym