#1
|
|||
|
|||
Adapting Macropod's Acronym Word VBA Code for Excel
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 Code:
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 |
#2
|
||||
|
||||
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. |
#3
|
|||
|
|||
Thanks, P45L! You've given me some good suggestions to try! I think the binding is causing a hiccup.
Much appreciated, Roy |
#4
|
|||
|
|||
Thanks again, P45L! You were right - the binding was messing me up.
Roy |
Tags |
word vba |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Acronym Finder Macro for Microsoft Word | mars1886 | Word VBA | 15 | 03-30-2022 06:56 AM |
@Macropod Macro VBA LINK Fields Relative Paste Special as Image from Excel word bug | ggll | Word | 0 | 09-18-2021 11:48 PM |
Mailmerge line graphs with Macropod's demo | gnoles | Mail Merge | 1 | 08-30-2019 07:25 AM |
Acronym lister and definition checker for Microsoft Word | gwez | Word VBA | 1 | 06-13-2015 04:00 AM |
Adapting a line shape | NikkiB | Word | 4 | 03-18-2013 08:45 AM |