[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 761
  • Last Modified:

Need help with modifying VBA code

I have an acronym finder macro that scans a Word documents and locates any acronyms (upper case terms) in that document; it then creates a new word document and inserts the found acronyms (w/o duplicates) in ASC order.

Please see attached Word document "TestDocument.docx" and execute macro "ExtractAllAcronymsToNewDocument" for a demonstration.

So far so good... this macro works great.

Now, here's what I need some help with.    Instead of adding the found acronyms into a new Word document, I would like to open an existing Excel spreadsheet (e.g., "Aconyms.xlsx") and add all acronyms (again, no duplicates) in ASC order... starting in cell A2.  

So, my question, how can the existing macro code be modified to accomplish this?

Note:  Please ensure to update the file path (wrkFile.Open) in the two Excel functions:  Extract_Acronyms_to_Excel() and AutomateExcel()

Thanks,
EEH
TestDocument.docx
Aconyms.xlsx
0
ExpExchHelp
Asked:
ExpExchHelp
2 Solutions
 
FlysterCommented:
Your macro was not included with the document. Can you please post it here?

Flyster
0
 
ExpExchHelpAuthor Commented:
Flyster:

My apologies... it was my mistake.   I thought it would have included the code (that I had added to the Word document).

Anyhow, please find attached text file which contains 3 functions:
1. Sub Extract_Acronyms_to_Excel()
2. Sub AutomateExcel()
3. Sub ExtractAllAcronymsToNewDocument()

... where # 3 is the function that successfully imports acronyms into a new document.

Not sure if #1 and #2 can be (or should be) combined.   For right now, unless it's causing a problem, let's leave them separate.  

So, whatever code is working for the Word function, I'd like to also have in the two (or one) Excel function.    

Most importantly though:
- I don't want to list duplicates (Word function only shows first occurrence)
- They need to be sorted in ASC order
- First acronym is added in cell A2, second one in A3, and so forth

Any help is greatly appreciated.

EEH

P.S.  Also, please ensure to add the >> Microsoft Excel 11.0 Object Library (or 12.0) to the Tools | References (in VBA) <<
MacroCode.txt
0
 
aikimarkCommented:
How big are your documents?
How many acronyms will you typically find in a document?

I'm not a big fan of concatenation as a substitute for a list if there is a chance of the string being large.

I usually recommend populating a dictionary object and use the object's Exists() method to detect collisions/duplicates.

Since the final destination is Excel, you can put all the found acronyms in a worksheet and use the AdvancedFilter method with a Unique:=True parameter to create your desired unique-value list.
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
ExpExchHelpAuthor Commented:
aikimark:

Potentially, a document could contain several hundred acronyms.

As I'm trying to automate this process (office), I want to stay focused on inserting them into an Excel file.  

Do you know how to use the code from the Word function and modify the code for the one/two Excel functions?

Thanks,
EEH
0
 
krishnakrkcCommented:
Hi

Try this

Sub ExtractAllAcronymsToNewDocument()

    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
    
    Dim objDic      As Object
    
    Set objDic = CreateObject("scripting.dictionary")
        objDic.comparemode = 1
        
    
    Title = "Extract Acronyms to New Document"
    Msg = "This macro will extract all acronyms to a separate document and alphabetize them with page numbers showing their first use"
        MsgBox Msg, vbOKOnly, Title
    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
    
    With oDoc_Source
        Set oRange = .Range
        
        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]{2" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute
                'Continue while found
                strAcronym = oRange
                'Put in dictionary object
                objDic.Item(strAcronym) = oRange.Information(wdActiveEndPageNumber)
            Loop
        End With
    End With
    
    'If no acronyms found, show msg and close new document without saving
    'Else keep open
    n = objDic.Count
    If n = 0 Then
        Msg = "No acronyms found."
        oDoc_Target.Close savechanges:=wdDoNotSaveChanges
    Else
        Dim appXl As Excel.Application
        Dim wrkFile As Excel.Workbooks
        Dim wbkOpen As Excel.Workbook
        
        Dim Acronyms    As Variant
        
        'Set object variables.
        Set appXl = New Excel.Application
        Set wrkFile = appXl.Workbooks
        
        
        'Display Excel.
        appXl.Visible = True
        
        'Open a file.
        'wrkFile.Open "C:\Users\Tom\Desktop\Macro\Acronyms.xls"
        
        Set wbkOpen = wrkFile.Open(oDoc_Source.Path & "\Aconyms.xlsx")
        
        Acronyms = TransposeArray(Array(objDic.keys, objDic.items))
        
        
        With wbkOpen.Worksheets(1)
            .Range("a1:b1") = [{"Acronym","Page"}]
            .Range("a2").Resize(n, 2) = Acronyms
            .Range("a2:b" & n + 1).Sort .Range("a2"), 1, header:=xlNo
        End With
        Msg = "Finished extracting " & n & " acronymn(s) to a Excel workbook."
    End If
    
    MsgBox Msg, vbOKOnly, Title
    
    'Clean up
    Set oRange = Nothing
    Set oDoc_Source = Nothing
    Set oDoc_Target = Nothing
    Set oTable = Nothing
    
End Sub
Function TransposeArray(ByRef Arr)
    
    Dim i   As Long
    Dim j   As Long
    Dim t()
    
    ReDim t(1 To UBound(Arr) + 1, 1 To UBound(Arr(0)) + 1)
    
    For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr(i)) To UBound(Arr(i))
            t(j + 1, i + 1) = Arr(i)(j)
        Next
    Next
    
    TransposeArray = t
    
End Function

Open in new window


Kris
0
 
ExpExchHelpAuthor Commented:
krishnakrkc:

Thank you... I think this is the 98% solution.

Upon copying/pasting the code into my Word document, I've made one code change.  

Changed:
From: Set wbkOpen = wrkFile.Open(oDoc_Source.Path & "\Aconyms.xls")
To: Set wbkOpen = wrkFile.Open("C:\Users\Tom\Desktop\Macro\Acronyms.xls")

I then executed the macro and it inserted the two test acronyms into the XLS.

So far so good...

Then, for testing purposes, I've added another test acronym (e.g., KLML) into the second paragraph.   That is, "Currently, these acronyms are placed into a new Word document.   Instead though, I’d like them to be added into an Excel KLMO file (starting at cells A2 to A###)."

At this time, I've got a run-time error #9 "Subscript out of range".    So, I presume it either doesn't "like" a more than 3-letter term or it doesn't accept additional terms.  

Could you please let me know what might be causing this?   Again, the actual documents to be scanned will have the following terms:

1. Document may contain hundreds of terms
2. Some terms may be listed only once... others may be listed several times throughout the document
3. Some acronyms may be up to 10-characters (or more) in length (i.e., some words might be just capitalized... doesn't mean it's an acronym... but that's ok).

Thousand thanks in advance!!

EEH
0
 
aikimarkCommented:
I'm not sure if this is substantively different than Kris's.
I'm using a data transfer technique I describe in my Fast Data Push to Excel article:
http://www.experts-exchange.com/A_2253.html
Option Explicit

Public Sub Q_27865018()
    Dim oDoc_Source As Document
    Dim oRange As Range
    Dim lngCount As Long
    Dim strListSep As String
    Dim dicUnique As Object
    Dim strAcronym As String
    Dim appXl As Object
    Dim wks As Object
    Dim vKeys As Variant
    Dim wkb As Object
    Dim vDataArray() As Variant
    Dim lngLoop As Long
    
    Set appXl = CreateObject("excel.application")
    Set dicUnique = CreateObject("scripting.dictionary")
    
    strListSep = Application.International(wdListSeparator)

    Set oDoc_Source = ActiveDocument
    
    'Create new document for acronyms
    
    With oDoc_Source
        Set oRange = .Range
        
        lngCount = 1 'used to count below
        
        With oRange.Find
            'Use wildcard search to find strings consisting of 2 or more uppercase letters
            'Set the search conditions
            'NOTE: If you want to find acronyms with 2 or more letters,
            'change 3 to 2 in the line below
            .Text = "<[A-Z]{2" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute
                'Continue while found
                strAcronym = oRange.Text
                
                'If strAcronym is already in strAllFound, do not add again
                If dicUnique.Exists(strAcronym) Then
                Else
                    dicUnique.Add strAcronym, 1
                End If
            Loop
        End With
    End With
    vKeys = dicUnique.keys
    ReDim vDataArray(LBound(vKeys) To UBound(vKeys), 0)
    'transfer the acronyms to a 2D array for transfer to Excel
    For lngLoop = LBound(vKeys) To UBound(vKeys)
        vDataArray(lngLoop, 0) = vKeys(lngLoop)
    Next
    
    Set wkb = appXl.Workbooks.Open("C:\Users\Tom\Desktop\Macro\Acronyms.xls")
    Set wks = wkb.sheets(1)
    wks.Range(wks.Cells(2, 1), wks.Cells(dicUnique.Count + 1, 1)).Value = vDataArray()
    wks.Range("a2").currentregion.Sort wks.Cells(2, 1), 1, Header:=1
    wkb.Save
    wkb.Close
    Set wkb = Nothing
    Set appXl = Nothing
End Sub

Open in new window

0
 
ExpExchHelpAuthor Commented:
aikimark:

That's the 99.9% solution.    Only thing that's missing is the feedback (i.e., pop-up) indicating the n number of acronyms were added to the XLS...

Followed by opening up the XLS.

Where would I put this code again?

Thanks,
EEH
0
 
aikimarkCommented:
I added a msgbox statement and made the Excel app object visible.  In this version of the code, I no longer save and close the workbook.
Option Explicit

Public Sub Q_27865018()
    Dim oDoc_Source As Document
    Dim oRange As Range
    Dim lngCount As Long
    Dim strListSep As String
    Dim dicUnique As Object
    Dim strAcronym As String
    Dim appXl As Object
    Dim wks As Object
    Dim vKeys As Variant
    Dim wkb As Object
    Dim vDataArray() As Variant
    Dim lngLoop As Long
    
    Set appXl = CreateObject("excel.application")
    Set dicUnique = CreateObject("scripting.dictionary")
    
    strListSep = Application.International(wdListSeparator)

    Set oDoc_Source = ActiveDocument
    
    'Create new document for acronyms
    
    With oDoc_Source
        Set oRange = .Range
        
        lngCount = 1 'used to count below
        
        With oRange.Find
            'Use wildcard search to find strings consisting of 2 or more uppercase letters
            'Set the search conditions
            'NOTE: If you want to find acronyms with 2 or more letters,
            'change 3 to 2 in the line below
            .Text = "<[A-Z]{2" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            
            'Perform the search
            Do While .Execute
                'Continue while found
                strAcronym = oRange.Text
                
                'If strAcronym is already in strAllFound, do not add again
                If dicUnique.Exists(strAcronym) Then
                Else
                    dicUnique.Add strAcronym, 1
                End If
            Loop
        End With
    End With
    vKeys = dicUnique.keys
    ReDim vDataArray(LBound(vKeys) To UBound(vKeys), 0)
    'transfer the acronyms to a 2D array for transfer to Excel
    For lngLoop = LBound(vKeys) To UBound(vKeys)
        vDataArray(lngLoop, 0) = vKeys(lngLoop)
    Next
    
    Set wkb = appXl.Workbooks.Open("C:\Users\Tom\Desktop\Macro\Acronyms.xls")
    Set wks = wkb.sheets(1)
    wks.Range(wks.Cells(2, 1), wks.Cells(dicUnique.Count + 1, 1)).Value = vDataArray()
    wks.Range("a2").currentregion.Sort wks.Cells(2, 1), 1, Header:=1
    Msgbox dicUnique.Count & " unique acronyms found" 
    appXL.Visible = True
'    wkb.Save
'    wkb.Close
    Set wkb = Nothing
    Set appXl = Nothing
End Sub

Open in new window

0
 
ExpExchHelpAuthor Commented:
aikimark -- thank you for providing this solution... I'm confident that it addresses all the requirements.   (I'll do some additional testing but for right now it looks great).

krishnakrkc -- thank you for your assistance as well... it looked like it addressed the question but in the end, longer acronyms resulted in throwing a run-time error.

That said, the best solution was provided by aikimark (400 pts)... but I wanted to also acknowledge the work by krish... hopefully that's ok by the two of you.

Again, thanks!

EEH
0

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now