VBA macro for MS Word to round numeric values in text selection with other characters before or afte-CodePudding

I want to write VBA code to round numbers embedded in text in a selection in Word. Unlike many solutions for rounding on the net, the values are not isolated in table cells etc. but may be in the text and have additional characters around them. Examples are: 0.0044***, (0.0040–0.0047) /-0.0012. I adapted the following code from this post which was designed to round to whole numbers:

Sub RoundNumbers()
Dim OrigRng As Range
Dim WorkRng As Range
Dim FindPattern As String
Dim FoundVal As String
Dim decplace as Integer
Set OrigRng = Selection.Range
Set WorkRng = Selection.Range
FindPattern = "([0-9]){1,}.[0-9]{1,}"
decplace = 3
Do
    With WorkRng
        .SetRange OrigRng.Start, OrigRng.End ' using "set WorkRng = OrigRng" would cause them to point to the same object (OrigRng is also changed when WorkRng is changed)
        If .Find.Execute(findtext:=FindPattern, Forward:=True, _
                MatchWildcards:=True) Then
            .Expand wdWord ' I couldn't find a reliable way for greedy matching with Word regex, so I expand found range to word
            .Text = FormatNumber(Round(CDbl(.Text)   0.000001, decplace), decplace, vbTrue)
        End If
    End With
Loop While WorkRng.Find.Found
End Sub

I thought I could extend the Round function to round to a specified number of decimals, e.g. .Text = round(CDbl(.Text) 0.000001, 3) The problem with this is that the macro continues to find the first value in the selection and doesn't move to subsequent numbers. Presumably this is because, unlike the whole numbers, the rounded values still match the regex. A solution suggested was to replace the count of digits post decimal from one or more {1,} with a fixed value e.g., {4}. This works if all the values to be rounded have the same format but doesn't have the flexibility I need.

So how can I get it to move to the next value? Alternatively, does anyone have a better solution?

CodePudding user response：

I think the issue you have is that you are not changing the range to reflect the text left to search. You seem to be resetting to the start of the range each time.

The following code may help

Option Explicit


Public Sub RoundNumbers(ByVal ipRange As wordRange)
    
    Dim myRange As Word.Range
    If ipRange Is Nothing Then
        
        Set myRange = ActiveDocument.StoryRanges(wdMainTextStory)
        
    Else
    
        Set myRange = ipRange.Duplicate
        
    End If
    
    Dim myPreservedRangeEnd As Long
    myPreservedRangeEnd = myRange.End
    
    Dim myFindPattern As String
    myFindPattern = "[0-9]{1,}.[0-9]{1,}"
    
    Dim myDecplace As Long
    myDecplace = 3
    
    Do
    
        Set myRange = FindWildCardPattern(myRange, myFindPattern)
        If myRange Is Nothing Then
            Exit Do
        End If
    
        myRange.Text = FormatNumber(Round(CDbl(myRange.Text)   0.000001, myDecplace), myDecplace, vbTrue)
        ' At this point myRange is the newly inserted text so to search
        ' the remainder of the text in the selection we need to move
        ' the start to after the current range and replace the end of the
        ' current range with the preserved end of the selection range
        myRange.Start = myRange.End   1
        myRange.End = myPreservedRangeEnd
        
    Loop
        
End Sub



Public Function FindWildCardPattern(ByVal ipRange As Range, ipFindPattern As String) As Range

    If ipRange Is Nothing Then

        Set ipRange = ActiveDocument.StoryRanges(wdMainTextStory)
        
    End If
    
    With ipRange
    
        With .Find
        
            .Text = ipFindPattern
            .Forward = True
            .MatchWildcards = True
            .Execute
            
        End With
            
        If .Find.Found Then
        
            Set FindWildCardPattern = .Duplicate
            
        Else
        
            Set FindWildCardPattern = Nothing
            
        End If
        
    End With
        
End Function

CodePudding user response：

The essential problem in your code is that you have the loop in the wrong place, and you set WordRng back to the beginning with each loop. Absent any example text I used the text in your question to test. The following should work:

Sub RoundNumbers()
    Dim WorkRng As Range: Set WorkRng = Selection.Range
    Dim FindPattern As String: FindPattern = "([0-9]){1,}.[0-9]{1,}"
    Dim FoundVal As String
    Dim decplace As Integer
  
    decplace = 3
    With WorkRng
        With .Find
            .ClearFormatting
            .Text = FindPattern
            .Forward = True
            .Wrap = wdFindStop
            .MatchWildcards = True
        End With
        Do While .Find.Execute
            .Text = FormatNumber(Round(CDbl(.Text)   0.000001, decplace), decplace, vbTrue)
        Loop
    End With
End Sub

CodePudding user response：

For example, to process a whole document:

Sub DemoA()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "<[0-9]@.[0-9]@>"
  End With
  Do While .Find.Execute = True
    .Text = Format(.Text, "0.000")
   .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub

or to process just a selected range:

Sub DemoB()
Application.ScreenUpdating = False
Dim Rng As Range
With Selection
  Set Rng = .Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "<[0-9]@.[0-9]@>"
  End With
  Do While .Find.Execute = True
    If .InRange(Rng) = False Then Exit Do
    .Text = Format(.Text, "0.000")
   .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub