UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> VBA - Creating An Acronym List, Office 2010    
 
   
midnight_puppy_2...
post Aug 25 2014, 10:16 AM
Post#1



Posts: 24
Joined: 25-July 14



Hello,
I found these lines of codes on word.tips.net to create an Acronym List. However, their acronym-definition structure is opposite to how I want it to be. For example:
  • Their structure (so that an acronym is recognized): FBI (Federal Bureau of Investigation)
  • How I want it to be: Federal Bureau of Investigation (FBI)

I want to modify the codes but don't know how. Please help me out.
CODE
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
Go to the top of the page
 
doctor9
post Aug 25 2014, 10:56 AM
Post#2


Remembered
Posts: 18,324
Joined: 29-March 05
From: Wisconsin


midnight_puppy_2303,
Assuming you want everything the same except for the output, you should just need to alter this one line of code:
CODE
                    strOutput = strOutput & strAcronym _
                      & vbTab & strDefine & vbCr

Since the macro is looking for instances of text with parentheses, i.e. "(Federal Bureau of Investigation)", you can strip the parentheses from strDefine and add them to strOutput in this line as well.
Hope this helps,
Dennis
Go to the top of the page
 
midnight_puppy_2...
post Aug 25 2014, 11:19 AM
Post#3



Posts: 24
Joined: 25-July 14



Dennis,
Thanks for your attempt to help me (yet again!). I'm sorry I didn't make it clear enough. I want the output to be the same. What I want to change is how the macro recognizes the "syntax". Right now it only is able to recognize "UUT (Unit Under Test)", while I want it to be able to recognize "Unit Under Test (UUT)" instead.
Go to the top of the page
 
doctor9
post Aug 25 2014, 12:24 PM
Post#4


Remembered
Posts: 18,324
Joined: 29-March 05
From: Wisconsin


midnight_puppy_2303,
In that case, you've got a bit harder task, I think. Right now, I think the macro is searching for a word that begins and ends with a capital letter, then when it finds that, it looks for the parentheses, which define the long version of the acronym.
In your case, you'll need to find the acronym, then search BACKWARDS several words, without the benefit of the parentheses delineating when to stop. You need to figure out where the definition of the abbreviation begins. I'm not sure how you'd know when to stop, except maybe to loop through the acroynym itself, and compare the letters to the first letters of each preceding word.
For example:
You encounter "FBI", so you loop backwards through each preceding word. The first one is "Investigation", which matches with "I". The next word is "of", which does not match "B". The next word is "Bureau" which matches with "B". The next word is "Federal" which matches with "F", which is the first letter of the abbreviation.
Hope this helps,
Dennis
Go to the top of the page
 
midnight_puppy_2...
post Aug 25 2014, 03:16 PM
Post#5



Posts: 24
Joined: 25-July 14



Thanks! Great outlines! But I think what you suggested is beyond my capability. The only programming background that I have is Pascal, which barely helps editing VBA codes, let alone compiling them. Please let me know if anyone comes up with another approach (without using VBA codes, maybe?).
Go to the top of the page
 
doctor9
post Aug 25 2014, 03:22 PM
Post#6


Remembered
Posts: 18,324
Joined: 29-March 05
From: Wisconsin


midnight puppy,
I took a stab at it, just to see what I could come up with. See if this works for you...
I added comments so you can see what's happening at every step.
Hope this helps,
Dennis
Attached File(s)
Attached File  2485040.zip ( 1.67K )Number of downloads: 65
 
Go to the top of the page
 
midnight_puppy_2...
post Aug 26 2014, 09:26 AM
Post#7



Posts: 24
Joined: 25-July 14



Dennis,
I copied the VBA codes from your last post yesterday. Everything works perfectly except for the output format, to which I had no problem making a few changes. Also, it is so nice of you to post a macro-enabled Word file as an attachment.
I have one more thing to ask: How do you send Word files loaded with macros to other people? Yesterday I created a macro using your codes, saved the file and sent it to my co-worker via email. However, when she opened it up, no macros were found. What do I need to do?
Go to the top of the page
 
doctor9
post Aug 26 2014, 10:08 AM
Post#8


Remembered
Posts: 18,324
Joined: 29-March 05
From: Wisconsin


midnight_puppy_2303,
First, make sure the code is saved in a code module within the file you want to send, and not in the "Normal" template file that opens whenever you open Word. One simple way to do this is to start the Macro Recorder while you're viewing the document you want to send. When the "Record Macro" dialog box opens, set the "Store macro in" combobox to the current document, not "All Documents". Then, record yourself hitting the spacebar or something, then stop the recorder. Now there should be a code module with your tiny recorded macro in it. Place the code you want to send to your coworker in the same code module.
Next, make sure you save your file as a Word Macro-Enabled Document.
Hope this helps,
Dennis
Go to the top of the page
 
midnight_puppy_2...
post Aug 26 2014, 11:38 AM
Post#9



Posts: 24
Joined: 25-July 14



Amazing! I tried different ways such as creating a template, saving as a 2003 doc, etc. but none of them worked. What a useful trick!
Thank you so much for your time and dedication, sir. I hope you have a good day!
Go to the top of the page
 
Shrutika
post May 22 2019, 05:29 AM
Post#10



Posts: 1
Joined: 22-May 19



Dennis,

I tried using the attachment with macros to prepare a 'list of abbreviation' along with their respective definitions; however, I am facing issues with this and I am unable to get the output. I have this another macro which gives me an output with all the acronyms and the page numbers they are located on. Can you help me to modify it in a way to also include the definitions to the acronyms. Please note, my document contains the acronyms and their definition in the following format definition (acronym for e.g.: deoxyribonucleic acid (DNA)).

The MACRO I am currently using is:

CODE
Dim oDoc_Source As Document
    Dim oDoc_Target As Document
    Dim strListSep As String
    Dim strAcronym As String
    Dim oTable As Table
    Dim oRange As Range
    Dim n As Long
    Dim strAllFound As String
    Dim Title As String
    Dim Msg As String

    Title = "Extract Acronyms to New Document"
    
    'Show msg - stop if user does not click Yes
    Msg = "This macro finds all words consisting of 3 or more " & _
        "uppercase letters and extracts the words to a table " & _
        "in a new document where you can add definitions." & vbCr & vbCr & _
        "Do you want to continue?"

    If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    'Find the list separator from international settings
    'May be a comma or semicolon depending on the country
    strListSep = Application.International(wdListSeparator)
    
    'Start a string to be used for storing names of acronyms found
    strAllFound = "#"
    
    Set oDoc_Source = ActiveDocument
    
    'Create new document for acronyms
    Set oDoc_Target = Documents.Add
    
    With oDoc_Target
        'Make sure document is empty
        .Range = ""
    
        'Insert info in header - change date format as you wish
        .PageSetup.TopMargin = CentimetersToPoints(3)
        .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
            "Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
            "Created by: " & Application.UserName & vbCr & _
            "Creation date: " & Format(Date, "MMMM d, yyyy")
                
        'Adjust the Normal style and Header style
        With .Styles(wdStyleNormal)
            .Font.Name = "Arial"
            .Font.Size = 10
            .ParagraphFormat.LeftIndent = 0
            .ParagraphFormat.SpaceAfter = 6
        End With
    
        With .Styles(wdStyleHeader)
            .Font.Size = 8
            .ParagraphFormat.SpaceAfter = 0
        End With
        
        'Insert a table with room for acronym and definition
        Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
        With oTable
            '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
    
    With oDoc_Source
        Set oRange = .Range
        
        n = 1 'used to count below
        
        With oRange.Find
            'Use wildcard search to find strings consisting of 3 or more uppercase letters
            'Set the search conditions
            'NOTE: If you want to find acronyms with e.g. 2 or more letters,
            'change 3 to 2 in the line below
            .Text = "<[A-Z]{3" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute
                'Continue while found
                strAcronym = oRange
                'Insert in target doc
                
                'If strAcronym is already in strAllFound, do not add again
                If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
                    'Add new row in table from second acronym
                    If n > 1 Then oTable.Rows.Add
                    'Was not found before
                    strAllFound = strAllFound & strAcronym & "#"
                    
                    'Insert in column 1 in oTable
                    'Compensate for heading row
                    With oTable
                        .Cell(n + 1, 1).Range.Text = strAcronym
                        'Insert page number in column 3
                        .Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
                    End With
                    
                    n = n + 1
                End If
            Loop
        End With
    End With
    
    'Sort the acronyms alphabetically - skip if only 1 found
    If n > 2 Then
        With Selection
            .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
                :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
            
            'Go to start of document
            .HomeKey (wdStory)
        End With
    End If
        
    Application.ScreenUpdating = True
    
    'If no acronyms found, show msg and close new document without saving
    'Else keep open
    If n = 1 Then
        Msg = "No acronyms found."
        oDoc_Target.Close savechanges:=wdDoNotSaveChanges
    Else
        Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
    End If
    
    MsgBox Msg, vbOKOnly, Title
    
    'Clean up
    Set oRange = Nothing
    Set oDoc_Source = Nothing
    Set oDoc_Target = Nothing
    Set oTable = Nothing

Thank you in advance.
This post has been edited by Shrutika: May 22 2019, 05:35 AM
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    16th July 2019 - 09:27 PM