Modify maco - extract definition 1st then acronym within ( )

[Micosoftfun]

Is there a way to reverse the order of this macro (excract acronyms &
definitions)? Our acronyms are written as i.e., Blue Sky (BS), but this macro
is for the format: (BS) Blue Sky. It works beautifully, but just in the
wrong order. I certainly appreciate any advise or help I can get on this.

Sub ListAcronyms()
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
ActiveWindow.View.ShowHiddenText = False

'Loop to find all acronyms
Do
'Search for acronyms using wildcards
Selection.Find.ClearFormatting
With Selection.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
.Execute
End With

'Only process if something found
If Selection.Find.Found Then
'Make a string from the selection, add it to the
'output string
strAcronym = Selection.Text

'Look for definition
Selection.MoveRight Unit:=wdWord
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
strDefine = ""
If Selection.Text = "(" Then
While Selection <> ")"
strDefine = strDefine & Selection.Text
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
Wend
End If
Selection.Collapse Direction:=wdCollapseEnd
If Left(strDefine, 1) = "(" Then
strDefine = Mid(strDefine, 2, Len(strDefine))
End If
If strDefine > "" Then
'Check if the search result is in the Output string
'if it is, ignore the search result
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym _
& vbTab & strDefine & vbCr
End If
End If
End If
Loop Until Not Selection.Find.Found

'Create new document and change active document
Set newDoc = Documents.Add

'Insert the text
Selection.TypeText Text:=strOutput

'Sort it
newDoc.Content.Sort SortOrder:=wdSortOrderAscending
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
End Sub

Thank YOU!

 

[Doug Robbins - Word MVP]

The problem that I can see is how is the code supposed to know how many
words before the ( are to be included in the definition

Blue Sky (BS)
Big Blue Sky (BBS)

Does the acronym always consist of the same number of letters as there are
words in its definition?

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Micosoftfun]

Thank you for looking into this. You are so right. How is the code suppose
to know how many words?

Our acronymns are anywhere from 2 to 3, even 4 characters. If I could just
get the program to recognize the first capital letter which would be the
first word, of course. For instance, Now Is The Time (NITT). I guess I'm
dreaming. Thank you again.

:I

The problem that I can see is how is the code supposed to know how many
words before the ( are to be included in the definition

Blue Sky (BS)
Big Blue Sky (BBS)

Does the acronym always consist of the same number of letters as there are
words in its definition?

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

Is there a way to reverse the order of this macro (excract acronyms &
definitions)? Our acronyms are written as i.e., Blue Sky (BS), but this
macro
is for the format: (BS) Blue Sky. It works beautifully, but just in the
wrong order. I certainly appreciate any advise or help I can get on this.

Sub ListAcronyms()
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
ActiveWindow.View.ShowHiddenText = False

'Loop to find all acronyms
Do
'Search for acronyms using wildcards
Selection.Find.ClearFormatting
With Selection.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
.Execute
End With

'Only process if something found
If Selection.Find.Found Then
'Make a string from the selection, add it to the
'output string
strAcronym = Selection.Text

'Look for definition
Selection.MoveRight Unit:=wdWord
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
strDefine = ""
If Selection.Text = "(" Then
While Selection <> ")"
strDefine = strDefine & Selection.Text
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
Wend
End If
Selection.Collapse Direction:=wdCollapseEnd
If Left(strDefine, 1) = "(" Then
strDefine = Mid(strDefine, 2, Len(strDefine))
End If
If strDefine > "" Then
'Check if the search result is in the Output string
'if it is, ignore the search result
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym _
& vbTab & strDefine & vbCr
End If
End If
End If
Loop Until Not Selection.Find.Found

'Create new document and change active document
Set newDoc = Documents.Add

'Insert the text
Selection.TypeText Text:=strOutput

'Sort it
newDoc.Content.Sort SortOrder:=wdSortOrderAscending
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
End Sub

Thank YOU!

 

[Greg Maxey]

Not thoroughlty tested but may suit your needs:

Sub ListAcronyms()
Dim oRng As Word.Range
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document
Dim rngEndPoint As Range
Dim defRange As Word.Range
ActiveWindow.View.ShowHiddenText = False
Application.ScreenUpdating = False
Set oRng = ActiveDocument.Content
With oRng.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
While .Execute
Set rngEndPoint = oRng.Duplicate
rngEndPoint.Start = oRng.End
strAcronym = oRng.Text
Set defRange = oRng.Duplicate
defRange.MoveStartUntil Cset:="(", Count:=wdBackward
defRange.End = defRange.Start
If defRange.Characters.First.Previous = "(" Then
defRange.MoveEndUntil Cset:=")", Count:=wdForward
strDefine = defRange.Text
If strDefine > "" Then
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym & vbTab & strDefine & vbCr
End If
End If
End If
'rngEndPoint.Select
Wend
End With
Set newDoc = Documents.Add
'Insert and sort text
With newDoc
.Range.Text = strOutput
.Content.Sort SortOrder:=wdSortOrderAscending
End With
Application.ScreenUpdating = True
End Sub

Thank you for looking into this. You are so right. How is the code
suppose to know how many words?

Our acronymns are anywhere from 2 to 3, even 4 characters. If I
could just get the program to recognize the first capital letter
which would be the first word, of course. For instance, Now Is The
Time (NITT). I guess I'm dreaming. Thank you again.

:I

The problem that I can see is how is the code supposed to know how
many words before the ( are to be included in the definition

Blue Sky (BS)
Big Blue Sky (BBS)

Does the acronym always consist of the same number of letters as
there are words in its definition?

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

Is there a way to reverse the order of this macro (excract acronyms
& definitions)? Our acronyms are written as i.e., Blue Sky (BS),
but this macro
is for the format: (BS) Blue Sky. It works beautifully, but just
in the wrong order. I certainly appreciate any advise or help I
can get on this.

Sub ListAcronyms()
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
ActiveWindow.View.ShowHiddenText = False

'Loop to find all acronyms
Do
'Search for acronyms using wildcards
Selection.Find.ClearFormatting
With Selection.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
.Execute
End With

'Only process if something found
If Selection.Find.Found Then
'Make a string from the selection, add it to the
'output string
strAcronym = Selection.Text

'Look for definition
Selection.MoveRight Unit:=wdWord
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
strDefine = ""
If Selection.Text = "(" Then
While Selection <> ")"
strDefine = strDefine & Selection.Text
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
Wend
End If
Selection.Collapse Direction:=wdCollapseEnd
If Left(strDefine, 1) = "(" Then
strDefine = Mid(strDefine, 2, Len(strDefine))
End If
If strDefine > "" Then
'Check if the search result is in the Output string
'if it is, ignore the search result
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym _
& vbTab & strDefine & vbCr
End If
End If
End If
Loop Until Not Selection.Find.Found

'Create new document and change active document
Set newDoc = Documents.Add

'Insert the text
Selection.TypeText Text:=strOutput

'Sort it
newDoc.Content.Sort SortOrder:=wdSortOrderAscending
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
End Sub

Thank YOU!

 

[Greg Maxey]

Doh!! After posting earlier I realized that your format is Blue Sky (BS) and
not (Blue Sky) BS. Sorry.

Not thoroughlty tested but may suit your needs:

Sub ListAcronyms()
Dim oRng As Word.Range
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document
Dim rngEndPoint As Range
Dim defRange As Word.Range
ActiveWindow.View.ShowHiddenText = False
Application.ScreenUpdating = False
Set oRng = ActiveDocument.Content
With oRng.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
While .Execute
Set rngEndPoint = oRng.Duplicate
rngEndPoint.Start = oRng.End
strAcronym = oRng.Text
Set defRange = oRng.Duplicate
defRange.MoveStartUntil Cset:="(", Count:=wdBackward
defRange.End = defRange.Start
If defRange.Characters.First.Previous = "(" Then
defRange.MoveEndUntil Cset:=")", Count:=wdForward
strDefine = defRange.Text
If strDefine > "" Then
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym & vbTab & strDefine & vbCr
End If
End If
End If
'rngEndPoint.Select
Wend
End With
Set newDoc = Documents.Add
'Insert and sort text
With newDoc
.Range.Text = strOutput
.Content.Sort SortOrder:=wdSortOrderAscending
End With
Application.ScreenUpdating = True
End Sub

Thank you for looking into this. You are so right. How is the code
suppose to know how many words?

Our acronymns are anywhere from 2 to 3, even 4 characters. If I
could just get the program to recognize the first capital letter
which would be the first word, of course. For instance, Now Is The
Time (NITT). I guess I'm dreaming. Thank you again.

:I

The problem that I can see is how is the code supposed to know how
many words before the ( are to be included in the definition

Blue Sky (BS)
Big Blue Sky (BBS)

Does the acronym always consist of the same number of letters as
there are words in its definition?

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of
my services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

message Is there a way to reverse the order of this macro (excract acronyms
& definitions)? Our acronyms are written as i.e., Blue Sky (BS),
but this macro
is for the format: (BS) Blue Sky. It works beautifully, but just
in the wrong order. I certainly appreciate any advise or help I
can get on this.

Sub ListAcronyms()
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
ActiveWindow.View.ShowHiddenText = False

'Loop to find all acronyms
Do
'Search for acronyms using wildcards
Selection.Find.ClearFormatting
With Selection.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
.Execute
End With

'Only process if something found
If Selection.Find.Found Then
'Make a string from the selection, add it to the
'output string
strAcronym = Selection.Text

'Look for definition
Selection.MoveRight Unit:=wdWord
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
strDefine = ""
If Selection.Text = "(" Then
While Selection <> ")"
strDefine = strDefine & Selection.Text
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
Wend
End If
Selection.Collapse Direction:=wdCollapseEnd
If Left(strDefine, 1) = "(" Then
strDefine = Mid(strDefine, 2, Len(strDefine))
End If
If strDefine > "" Then
'Check if the search result is in the Output string
'if it is, ignore the search result
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym _
& vbTab & strDefine & vbCr
End If
End If
End If
Loop Until Not Selection.Find.Found

'Create new document and change active document
Set newDoc = Documents.Add

'Insert the text
Selection.TypeText Text:=strOutput

'Sort it
newDoc.Content.Sort SortOrder:=wdSortOrderAscending
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
End Sub

Thank YOU!

 

[Jim Haas]

I think trying to extract the acronym definition is ideal, but more ambitious than really necessary. I'd settle for pulling out enough context into the resulting table that I wouldn't have to go back to the source document to confirm that the acronym meant what I thought it did. I'd like to pull out the -n- words preceding each acronym and incorporate it into a new column.

The new table would consist of these columns:
Acronym, Definition (left blank), Context (Prior -n- words), and page number.

The user could then easily cut/paste what he wanted from the Context column or just use it as guidance to key in the proper definition.

I tried to do that, cobbling code from the example, but my base macro was lifted from Lene Fredborg/doctools, which differs from the one in this thread; I get null in the context column.

thanks.

jbh

Is there a way to reverse the order of this macro (excract acronyms &
definitions)? Our acronyms are written as i.e., Blue Sky (BS), but this macro
is for the format: (BS) Blue Sky. It works beautifully, but just in the
wrong order. I certainly appreciate any advise or help I can get on this.

Sub ListAcronyms()
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document

Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
ActiveWindow.View.ShowHiddenText = False

'Loop to find all acronyms
Do
'Search for acronyms using wildcards
Selection.Find.ClearFormatting
With Selection.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
.Execute
End With

'Only process if something found
If Selection.Find.Found Then
'Make a string from the selection, add it to the
'output string
strAcronym = Selection.Text

'Look for definition
Selection.MoveRight Unit:=wdWord
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
strDefine = ""
If Selection.Text = "(" Then
While Selection <> ")"
strDefine = strDefine & Selection.Text
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, _
Extend:=wdExtend
Wend
End If
Selection.Collapse Direction:=wdCollapseEnd
If Left(strDefine, 1) = "(" Then
strDefine = Mid(strDefine, 2, Len(strDefine))
End If
If strDefine > "" Then
'Check if the search result is in the Output string
'if it is, ignore the search result
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym _
& vbTab & strDefine & vbCr
End If
End If
End If
Loop Until Not Selection.Find.Found

'Create new document and change active document
Set newDoc = Documents.Add

'Insert the text
Selection.TypeText Text:=strOutput

'Sort it
newDoc.Content.Sort SortOrder:=wdSortOrderAscending
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
End Sub

Thank YOU!

On Wednesday, April 14, 2010 1:27 AM Doug Robbins - Word MVP wrote:
The problem that I can see is how is the code supposed to know how many
words before the ( are to be included in the definition

Blue Sky (BS)
Big Blue Sky (BBS)

Does the acronym always consist of the same number of letters as there are
words in its definition?

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

Sub ListAcronyms()
Dim oRng As Word.Range
Dim strAcronym As String
Dim strDefine As String
Dim strOutput As String
Dim newDoc As Document
Dim rngEndPoint As Range
Dim defRange As Word.Range
ActiveWindow.View.ShowHiddenText = False
Application.ScreenUpdating = False
Set oRng = ActiveDocument.Content
With oRng.Find
.ClearFormatting
.Text = "<[A-Z]@[A-Z]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.MatchWholeWord = True
While .Execute
Set rngEndPoint = oRng.Duplicate
rngEndPoint.Start = oRng.End
strAcronym = oRng.Text
Set defRange = oRng.Duplicate
defRange.MoveStartUntil Cset:="(", Count:=wdBackward
defRange.End = defRange.Start
If defRange.Characters.First.Previous = "(" Then
defRange.MoveEndUntil Cset:=")", Count:=wdForward
strDefine = defRange.Text
If strDefine > "" Then
If InStr(strOutput, strAcronym) = 0 Then
strOutput = strOutput & strAcronym & vbTab & strDefine & vbCr
End If
End If
End If
'rngEndPoint.Select
Wend
End With
Set newDoc = Documents.Add
'Insert and sort text
With newDoc
.Range.Text = strOutput
.Content.Sort SortOrder:=wdSortOrderAscending
End With
Application.ScreenUpdating = True
End Sub





Micosoftfun wrote: