Automatic Excel Acronym finding and Definition add

Question

I regularly have to create documents at work and within the company we almost have a language of our own due to the number of acronyms and abbreviations we use. Consequently I got tired of manually creating an Acronym and abbreviation table before I could publish the document and a quick google search came across a macro that would effectively do it for me. (modified code shown below)

I modified this macro so that the table was pasted into the location of the cursor in the original document (this may not be the msot efficient way, but it was the simplest i could think of as I am not a VBA expert).

Since then I have realised that there must be a simple way to further speed up this process by automatically including the definitions as well. I have an excel spreadsheet with the Acronym in the first column and its definition in the second.

So far I have been able to get as far as opening the excel document but cannot seem to get a search which will return the row number and consequently use this to copy the contents of the definition cell next to it into the corresponding definition section of the table in Word.

** edit - extra explanation ** The current macro searches the word document and finds all the acronyms that have been used and places them in a table in a seperate word document. What i wish to do is have it also then search an excel file (pre-existing) for the definition of each of the found acronyms and add them also to the table or if they are new leave it blank. Finally the macro copies this table back into the original document.

This code currently fails saying the .Find function is not defined? (I have kept the code seperate for now to keep testing simple)

Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Range
Dim rngFound As Range


Set objDoc = ActiveDocument
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("P:\ENGINEERING\EL\Global Access\Abbreviations and Acronyms.xls")
objExcel.Visible = True
objWbk.Activate

With objExcel
With objWbk
Set rngSearch = objWbk.Range("A:A")
Set rngFound = rngSearch.Find(What:="AS345", LookIn:=xlValues, LookAt:=xlPart)

If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If

End With
End With

Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing

'MsgBox "The document has been updated"

Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
    Set objExcel = CreateObject("Excel.Application")
    Resume Next
ElseIf Err.Number <> 0 Then
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Err_Exit
End If

End Sub

Acronym extraction code

Sub ExtractACRONYMSToNewDocument()

'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'Modified in 2014 by David Mason to place the acronym table in the original document
'=========================

Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef 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:=2)
    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



'Copy the whole table, switch to the source document and past
'in the table at the original selection location
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste

'make the target document active and close it down without saving
oDoc_Target.Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

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

End Sub

Answer 1

So it would appear with some searching I found the solution to the problem. A big thank you to L42 who helped solve the problem regarding whether i was using Early or Late binding (I had no idea these were even different).

The remaining problem where the following error occured:

Compile Error: Named Argument not found

Was suprisingly easy to solve once I found the solution... you have to love hindsight. It turns out I had to define my two variables rngFound and rngSearch as objects. As soon as i made that change the code worked beautifully.

Here is the working code which I will then incorporate into my acronym macro. (will add the total code when complete)

Sub openExcel()

Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue

Set objDoc = ActiveDocument
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\DMASON2\Documents\Book1.xlsx")
objExcel.Visible = True
objWbk.Activate

With objWbk.Sheets("Sheet1")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
Set rngFound = rngSearch.Find(What:="AA", After:=.Range("A1"), LookAt:=1)

If rngFound Is Nothing Then
    MsgBox "Not found"
Else
    'MsgBox rngFound.Row


    targetCellValue = .Cells(rngFound.Row, 2).Value
    MsgBox (targetCellValue)
End If
End With


Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing

'MsgBox "The document has been updated"

Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
    Set objExcel = CreateObject("Excel.Application")
    Resume Next
ElseIf Err.Number <> 0 Then
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Err_Exit
End If

End Sub

** edit, complete code for searching and finding the acronyms along with their definitions **

Sub ExtractACRONYMSToNewDocument()


Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim m As Long
m = 0
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Dim objExcel As Object
Dim objWbk As Object
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue As String

' message box title
Title = "Extract Acronyms to New Document"

' Set message box message
Msg = "This macro finds all Acronyms (consisting of 2 or more " & _
"uppercase letters, Numbers or '/') and their associated definitions. It " & _
"then extracts the words to a table at the current location you have selected" & vbCr & vbCr & _
"Warning - Please make sure you check the table manually after!" & vbCr & vbCr & _
"Do you want to continue?"

' Display message box
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
    Exit Sub
End If

' Stop the screen from updating
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 = "#"

' give the active document a variable
Set oDoc_Source = ActiveDocument

'Crete a variable for excel and open the definition workbook
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\Dave\Documents\Test_Definitions.xlsx")
'objExcel.Visible = True
objWbk.Activate

'Create new document to temporarily store the acronyms
Set oDoc_Target = Documents.Add

' Use the target document
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:=2)
    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"

        '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

    End With
End With



With oDoc_Source
    Set oRange = .Range

    n = 1 'used to count below

    ' within the total range of the source document
    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][A-Z0-9/]{1" & 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

                    ' Find the definition from the Excel document
                    With objWbk.Sheets("Sheet1")
                        ' Find the range of the cells with data in Excel doc
                        Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))

                        ' Search in the found range for the
                        Set rngFound = rngSearch.Find(What:=strAcronym, After:=.Range("A1"), LookAt:=1)

                        ' if nothing is found count the number of acronyms without definitions
                        If rngFound Is Nothing Then
                            m = m + 1

                            ' Set the cell variable in the new table as blank
                            targetCellValue = ""

                        ' If a definition is found enter it into the cell variable
                        Else
                            targetCellValue = .Cells(rngFound.Row, 2).Value

                        End If
                    End With

                    ' enter the cell varibale into the definition cell
                    .Cell(n + 1, 2).Range.Text = targetCellValue
                End With


                ' add one to the loop count
                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

'Copy the whole table, switch to the source document and past
'in the table at the original selection location
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste

' update screen
Application.ScreenUpdating = True

'If no acronyms found set message saying so
If n = 1 Then
    Msg = "No acronyms found."

' set the final messagebox message to show the number of acronyms found and those that did not have definitions
Else
    Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document. Unable to find definitions for " & m & " acronyms."
End If

' Show the finished message box
AppActivate Application.Caption
MsgBox Msg, vbOKOnly, Title

'make the target document active and close it down without saving
oDoc_Target.Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

'Close Excel after
objWbk.Close Saved = True

'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
Set objExcel = Nothing
Set objWbk = Nothing



End Sub

Answer 2

You are just missing the Worksheet Object.
Also With objExcel can be ommited since you already pass the Workbook Object to objWbk variable.

With objWbk.Sheets("NameOfYourSheet")
    Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
    Set rngFound = rngSearch.Find(What:="AS345", After:=.Range("A1"), LookAt:=xlWhole)

    If rngFound Is Nothing Then
        MsgBox "Not found"
    Else
        MsgBox rngFound.Row
    End If
End With

In the above code, I assumed your Excel data have headers.

Edit1: Since you are Late Binding Excel, this should work:

With objWbk.Sheets("Sheet1")
    Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
    Set rngFound = rngSearch.Find(What:="AS345", After:=.Range("A1"), LookAt:=1)

    If rngFound Is Nothing Then
        MsgBox "Not found"
    Else
        MsgBox rngFound.Row
    End If
End With

Take note that we replaced xlUp with it's equivalent constant -4162 and xlWhole with 1.
To learn more about Early and Late Binding, check THIS out.
For additional information, you can also refer HERE.

Although it is dicussed in the link I provided, you might ask where do I get the constant?
Just open Excel or any other MS application you are binding then view Immediate Window - Ctrl+G
In the immediate window, type ? then the constant you want to get the numeric equivalent.
Example:

?xlUp
-4162
?xlWhole
1
?xlPart
2

Hope this somehow solves your problem.