Adapting Macropod's Acronym Word VBA Code for Excel

[scienceguy]

Hello all,

I am trying to adapt Macropod's, "Acronym and definition list generator" to run in Excel. (I'm using Excel, because this is one of many utilities I'm running on a document). I'm not really significantly modifying the code, except to open a Word file and run the code from Excel. Otherwise, the code is the same. Macropod's original code is here and works fine:

https://www.msofficeforums.com/word-...generator.html

For reasons I can't figure out, the modified code isn't finding any acronyms. My code is below, and I am attaching two files:

(1) acronym_app.xlsm (contains the code below)
(2) acronym finder3.docm (test document but also contains Macropod's original code)

Thanks for any assistance!

Sincerely,


Roy

Sub AcronymLister()

'code adapted from:
'https://www.msofficeforums.com/word-vba/42313-acronym-definiton-list-generator.html

Dim wdApp As Object
Dim wdDoc As Object
Dim aRng As Object
Dim strFile As String

'Application.ScreenUpdating = False

Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table

With Application.FileDialog(msoFileDialogOpen)

  If .Show = -1 Then
    strFile = .SelectedItems(1)
  End If

End With

If strFile = "" Then
    Exit Sub
End If

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

End If

Set wdDoc = wdApp.Documents.Open(Filename:=strFile, AddToRecentFiles:=False, Visible:=True)
Set aRng = wdDoc.Range

StrAcronyms = "Acronym" & vbTab & "Term" & vbTab & "Page" & vbTab & "Cross-Reference Count" & vbTab & "Cross-Reference Pages" & vbCr

  With aRng
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Wrap = wdFindStop
      .Text = "\([A-Z0-9][A-Z&0-9]{1" & Application.International(wdListSeparator) & "}\)"
      .Replacement.Text = ""
      .Execute
    End With
    
    'currently, code does not find anything!
    
    Do While .Find.Found = True
      StrTmp = Replace(Replace(.Text, "(", ""), ")", "")
      If (InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0) And (Not IsNumeric(StrTmp)) Then
        If .Words.First.Previous.Previous.Words(1).Characters.First = Right(StrTmp, 1) Then
          For i = Len(StrTmp) To 1 Step -1
            .MoveStartUntil Mid(StrTmp, i, 1), wdBackward
            .Start = .Start - 1
            If InStr(.Text, vbCr) > 0 Then
              .MoveStartUntil vbCr, wdForward
              .Start = .Start + 1
            End If
            If .Sentences.Count > 1 Then .Start = .Sentences.Last.Start
            If .Characters.Last.Information(wdWithInTable) = False Then
              If .Characters.First.Information(wdWithInTable) = True Then
                .Start = .Cells(.Cells.Count).Range.End + 1
              End If
            ElseIf .Cells.Count > 1 Then
              .Start = .Cells(.Cells.Count).Range.Start
            End If
          Next
        End If
        StrTmp = Replace(Replace(Replace(.Text, " (", "("), "(", "|"), ")", "")
        StrAcronyms = StrAcronyms & Split(StrTmp, "|")(1) & vbTab & Split(StrTmp, "|")(0) & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbTab & vbTab & vbCr
      End If
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  StrAcronyms = Replace(Replace(Replace(StrAcronyms, " (", "("), "(", vbTab), ")", "")
  Set Rng = wdDoc.Range.Characters.Last
  With Rng
    If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
    .InsertAfter Chr(12)
    .Collapse wdCollapseEnd
    .Style = "Normal"
    .Text = StrAcronyms
    Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=5)
    With Tbl
      .Columns.AutoFit
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.Style = "Strong"
      .Rows.Alignment = wdAlignRowCenter
    End With
    .Collapse wdCollapseStart
  End With
  For i = 2 To Tbl.Rows.Count
    StrTmp = "": j = 0: k = 0
    With aRng '.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .Text = Split(Tbl.Cell(i, 1).Range.Text, vbCr)(0)
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found = True
        If .InRange(Tbl.Range) Then Exit Do
        j = j + 1
        If j > 0 Then
          If k <> .Duplicate.Information(wdActiveEndAdjustedPageNumber) Then
            k = .Duplicate.Information(wdActiveEndAdjustedPageNumber)
            StrTmp = StrTmp & k & " "
          End If
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    Tbl.Cell(i, 4).Range.Text = j
    StrTmp = Replace(Trim(StrTmp), " ", ",")
    If StrTmp <> "" Then
      'Add the current record to the output list (StrOut)
      StrTmp = Replace(Replace(ParseNumSeq(StrTmp, "&"), ",", ", "), "  ", " ")
    End If
    Tbl.Cell(i, 5).Range.Text = StrTmp
  Next


Set Rng = Nothing: Set Tbl = Nothing
Set aRng = Nothing
Set wdDoc = Nothing
Set wdApp = nohting

Application.ScreenUpdating = True

MsgBox "Done!"

End Sub

[p45cal]

Just at first glance (I haven't looked in depth) I notice you're using late binding which could mean that many of the Word enumerations (eg. wdActiveEndAdjustedPageNumber) won't be recognised by Excel.
Either set a (temporary if you like) reference to Word in the VBE's Tools|References dialogue box: (see pic below)


or you'll need to find the value of each (and recognise them in the first place!) and replace them with their numerical value (1 in the case of wdActiveEndAdjustedPageNumber)


The line in your macro:
On Error Resume Next
is going to hide many errors from you, disable it and step through the code with F8 on the keyboard so that you can see which lines are going wrong.

[scienceguy]

Thanks, P45L! You've given me some good suggestions to try! I think the binding is causing a hiccup.

Much appreciated,
Roy

[scienceguy]

Thanks again, P45L! You were right - the binding was messing me up.

Roy