Microsoft Office Forums - View Single Post - [Solved] Find currency amounts in Word doc, perform sum

GWTJR · 10-15-2017, 10:29 AM

Dear Experts,
I have a requirement for a VBA macro and I am stumped! Here are the (deceptively simple) steps involved:

1. Find currency amounts in a Word document. Currency amounts appear in the following format: EUR 20.3m (meaning 20.3 million euros)
2. Extract only the numerical portion of the find string.
3. Perform a sum of all amounts found.

Background: Typically there are around 30-40 amounts to add up in a given document. The current method involves copying and pasting each amount manually into an Excel spreadsheet, then performing an auto sum. Obviously this consumes a large amount of time and needs to be automated if possible.

With that in mind I attempted to write up some VBA code to automate the above steps. I first tried initiating the macro from Word. Below is my poorly-written code:

Code:

Sub FindCopyPasteWordToExcel()

    Dim oXL As Excel.Application
    Dim oWB As Excel.Workbook
    Dim WorkbookToWorkOn As String
    
    'Specify the workbook to work on
    WorkbookToWorkOn = "C:\Users\ ... \Book1.xlsm"
    
    ' Open the workbook
    Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)
    
    With ActiveDocument.Range = wdWholeStory
    
        Selection.HomeKey
        Do
            With Selection.Find
                .ClearFormatting
                .Text = "(EUR )(*)(m)"
                .Replacement.Text = "\2"
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
                
            If .Found = True Then
                Selection.Copy
                oXL.ActiveSheet.Range("B1:B40").FindNext.Select
                oXL.ActiveCell.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
                oXL.ActiveWorkbook.Save
                oXL.ActiveWorkbook.Close
            Else
                MsgBox "No items were found."
            End If
        Loop Until ActiveDocument.Range.End
    End With
End Sub

The result in Excel was: only the first found instance of an amount was pasted into cell B2. The pasted result was "EUR 20.3m".

I next attempted to initiate the code in Excel, but I ended up stumped at the same result. Clearly I made the same mistakes in that code, so no need to add it.

I'm looking forward to hearing your feedback and suggestions. Thank you in advance for your time!