Find currency amounts in Word doc, perform sum

GWTJR · #1 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!

macropod · #2 10-15-2017, 01:38 PM

Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim Amt As Single
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "EUR [0-9.]@m"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    Amt = Amt + CSng(Split(Split(.Text, " ")(1), "m")(0))
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox "EUR " & Amt & "m"
End Sub

GWTJR · #3 10-15-2017, 02:18 PM

BRILLIANT! Thank you Paul. One day when you're bored, I'd love to get a better understanding of the .Find.Found loop. That's the key to understanding how to use the find results and manipulate the data as needed. Very much appreciated.

macropod · #4 10-15-2017, 02:22 PM

The .Find.Found simply returns True or False depending on whether the Find expression has been found. Putting it in a loop with:
.Collapse wdCollapseEnd
.Find.Execute
Simply causes Word to keep looking for more hits until .Find.Found returns False.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How do I create currency cells in a Word Table	DelHop	Word Tables	11	11-24-2019 02:37 PM
Adding addresses and $ amounts to Word docs	littlepeaks	Word VBA	2	01-22-2016 07:57 PM
Macro to find a word in first row of table and then perform two macros	hmsrose	Word VBA	5	01-30-2015 12:17 AM
Perform a search for alternative words	jungkim	Word	2	03-24-2012 07:40 AM
Perform Calculations using List boxes	Jennifer_Falcon	Word VBA	6	07-26-2011 10:49 AM