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.

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