Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-19-2021, 09:41 AM
scienceguy scienceguy is offline Adapting Macropod's Acronym Word VBA Code for Excel Windows 10 Adapting Macropod's Acronym Word VBA Code for Excel Office 2019
Advanced Beginner
Adapting Macropod's Acronym Word VBA Code for Excel
 
Join Date: Feb 2019
Posts: 46
scienceguy is on a distinguished road
Default 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
Attached Files
File Type: xlsm acronym_app.xlsm (30.7 KB, 5 views)
File Type: docm acronym finder3.docm (23.8 KB, 5 views)
Reply With Quote
  #2  
Old 11-20-2021, 06:21 AM
p45cal's Avatar
p45cal p45cal is offline Adapting Macropod's Acronym Word VBA Code for Excel Windows 10 Adapting Macropod's Acronym Word VBA Code for Excel Office 2019
Expert
 
Join Date: Apr 2014
Posts: 863
p45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant futurep45cal has a brilliant future
Default

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.
Attached Images
File Type: png 2021-11-20_132834.png (9.7 KB, 15 views)
Reply With Quote
  #3  
Old 11-20-2021, 06:30 AM
scienceguy scienceguy is offline Adapting Macropod's Acronym Word VBA Code for Excel Windows 10 Adapting Macropod's Acronym Word VBA Code for Excel Office 2019
Advanced Beginner
Adapting Macropod's Acronym Word VBA Code for Excel
 
Join Date: Feb 2019
Posts: 46
scienceguy is on a distinguished road
Default

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

Much appreciated,
Roy
Reply With Quote
  #4  
Old 11-20-2021, 06:59 AM
scienceguy scienceguy is offline Adapting Macropod's Acronym Word VBA Code for Excel Windows 10 Adapting Macropod's Acronym Word VBA Code for Excel Office 2019
Advanced Beginner
Adapting Macropod's Acronym Word VBA Code for Excel
 
Join Date: Feb 2019
Posts: 46
scienceguy is on a distinguished road
Default

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

Roy
Reply With Quote
Reply

Tags
word vba

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Adapting Macropod's Acronym Word VBA Code for Excel 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
Adapting Macropod's Acronym Word VBA Code for Excel 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

Other Forums: Access Forums

All times are GMT -7. The time now is 03:26 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft