[dba-Tech] Word VBA question

Thu Nov 7 13:37:54 CST 2019

I had to let this go for awhile but I've got it mostly worked out, except
for the right loop. 

This procedure creates a new document with a table for storing each acronym,
its, definition, and the page number. Right now, it works fine for the first
acronym found, but I can't get the loop correct to keep it going until it's
found all of the acronyms. 

Any help? 

At this point, don't worry if the definition isn't exact. I haven't been
able to test it for a full document -- can't do that until I can get the
loop to work. In addition, it's rather ugly code -- I'll clean it up later. 

Code follows -- and thanks! - Susan H. 

Sub GetAcronyms()
'Create new document with acronyms, definitions, and page numbers for active
document.

Dim source As Document
Dim target As Document
Dim rng As Range
Dim tbl As Table
Dim strAnronym As String
Dim strDefintion As String
Dim intAcronym As Integer
Dim strRngCopy As String

Set source = ActiveDocument
Set target = Documents.Add

'Add Table object to target document to organize anacronyms and definitions.
With oDoc_Target
    Set tbl = target.Tables.Add(target.Range, 2, 3)
    With tbl
        'Format the table a bit
        'Insert headings
        .Range.Style = wdStyleNormal
        .AllowAutoFit = False
        .Cell(1, 1).Range.Text = "Acronym"
        .Cell(1, 2).Range.Text = "Definition"
        .Cell(1, 3).Range.Text = "Page"
        'Set row as heading row
        .Rows(1).HeadingFormat = True
        .Rows(1).Range.Font.Bold = True
        .PreferredWidthType = wdPreferredWidthPercent
        .Columns(1).PreferredWidth = 20
        .Columns(2).PreferredWidth = 70
        .Columns(3).PreferredWidth = 10
    End With
End With

Set rng = source.Range

'Do While rng.Find.Found
With rng.Find
    'Use wildcard search to find strings consisting of two or more uppercase
letters.
    .Text = "\(<[A-Z]{2,}>"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = True
    .MatchWildcards = True
    'Perform the search
    .Execute
        strAcronym = Right(rng, Len(rng) - 1)
        'Length of strAcronym determines number of words preceding copied.
        'Copy acronym definition.
        intAcronym = Len(strAcronym)
        rng.Select
        strDefinition = Selection.MoveLeft(wdWord, intAcronym + 2, True)
        strDefinition = Selection.Text

        'Copy acronym, definition, and page number to target table.
        With tbl
            tbl.Select
            Selection.InsertRowsBelow 1
            tbl.Cell(2, 1).Range = strAcronym
            tbl.Cell(2, 3).Range.Text =
rng.Information(wdActiveEndPageNumber)
            tbl.Cell(2, 2).Range.Text = strDefinition
        End With

    End With
'Loop

End Sub

-----Original Message-----
From: dba-Tech <dba-tech-bounces at databaseadvisors.com> On Behalf Of
Salakhetdinov Shamil via dba-Tech
Sent: Saturday, August 31, 2019 8:09 AM
To: Discussion of Hardware and Software issues
<dba-tech at databaseadvisors.com>
Cc: Salakhetdinov Shamil <mcp2004 at mail.ru>
Subject: Re: [dba-Tech] Word VBA question

Hi Susan --

I'm not sure what method do you use to find the abbreviation - here are two
possible solution cases:

*** First one ***

Sub Macro1()
Dim searchWord As String
searchWord = "BBB"
Dim sel As word.Selection
Set sel = word.Application.Selection
sel.ClearFormatting
With sel.Find
.Text = searchWord
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Dim wordFound As Boolean
wordFound = sel.Find.Execute
If wordFound Then
Dim wordLength As Integer
wordLength = Strings.Len(searchWord)
Dim wdoc As word.Document
Set wdoc = word.Application.ActiveDocument

Dim wordIndex As Integer
wordIndex = GetWordIndex(wdoc, sel.Words.First.Start) If (wordIndex > -1)
Then Dim rangeToCopy As word.Range Set rangeToCopy =
wdoc.Range(wdoc.Words(wordIndex - wordLength - 1).Start,
wdoc.Words(wordIndex - 1).Start) Dim strToCopy As String strToCopy =
Strings.Trim(rangeToCopy) Debug.Print "'" + strToCopy + "'"
End If
End If
End Sub
Function GetWordIndex(wdoc As word.Document, wordStartPosition As Integer)
As Integer Dim wordIndex As Integer wordFound = False For wordIndex = 1 To
wdoc.Words.Count If (wdoc.Words(wordIndex).Start = wordStartPosition) Then
GetWordIndex = wordIndex Exit Function End If Next wordIndex

GetWordIndex = -1
End Function
*** Second one ***

Sub Macro2()
Dim searchWord As String
searchWord = "BBB"

Dim wdoc As word.Document
Dim wordIndex As Integer
Dim wordFound As Boolean

Set wdoc = word.Application.ActiveDocument wordFound = False For wordIndex =
1 To wdoc.Words.Count If (wdoc.Words(wordIndex) = searchWord) Then wordFound
= True Exit For End If Next wordIndex

If wordFound Then
Dim wordLength As Integer
wordLength = Strings.Len(searchWord)
Dim rangeToCopy As word.Range
Set rangeToCopy = wdoc.Range(wdoc.Words(wordIndex - wordLength - 1).Start,
wdoc.Words(wordIndex - 1).Start) Dim strToCopy As String strToCopy =
Strings.Trim(rangeToCopy) Debug.Print "'" + strToCopy + "'"

End If
End Sub HTH.

-- Shamil

P.S. I'm a rare guest here these days - if you have any questions on the
subject please e-mail me directly.

>Tuesday, August  6, 2019 12:21 AM +03:00 from Susan Harkins
<ssharkins at gmail.com>:
>
>Hi everyone!
>
>I need to copy a range to a new Word document, but it's a complicated 
>search. When the search pattern find a match, I need to select the 
>words to the left -- using the length of the match (which can change, 
>I'm using wildcards). I'm stumped.
>
>An example: 
>
>The search string matches (BBB) at the text, Better Business Bureau 
>(BBB). I need to copy the definition of the acronym, to the left of 
>BBB, and the acronym. The acronym is easy. But I can't figure out for 
>the life of me how to set a range to "three words to the left of BBB".
>
>I'd like to avoid using Selection because the editors will be working 
>with big documents. If that's the only way it can be done, that's the 
>route I'll go. But I'd rather set a range -- just can' figure out how to do
it.
>
>Thanks!
>Susan H. 
>
>_______________________________________________
>dba-Tech mailing list
>dba-Tech at databaseadvisors.com
>http://databaseadvisors.com/mailman/listinfo/dba-tech
>Website:  http://www.databaseadvisors.com

--
Salakhetdinov Shamil
_______________________________________________
dba-Tech mailing list
dba-Tech at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/dba-tech
Website: http://www.databaseadvisors.com