CODEWITHSUNDEEP
regexvbams-word
Artem Zefirov
Artem Zefirov

Reputation: 433

Delete trailing zeros with RegExp in VBA

I have several tables in my .docx file. Among numbers in these table some decimal numbers occur like "43,0" and "2,300". I've written a script in VBA for removing all trailing zeros:

Sub DeleteTrailingZeros()
Application.ScreenUpdating = False
Dim Tbl As Word.table
For Each Tbl In ActiveDocument.Tables
  With Tbl.Range.Find
   .ClearFormatting
   .Replacement.ClearFormatting
   .MatchWildcards = True
   .Text = "(\,\d*?[1-9])0+$"
   .Replacement.Text = "\1"
   .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindStop
 End With
Next Tbl
End Sub

However, it doesn't work. What can be the problem?

Edited: The version based on regular expressions. The pattern seems to be correct, but nothing is found. A coupled part of the expression seems to be not replaced correctly but simply deleted. Can't figure out why it happens.

Sub DeleteTrailZerosRegExp()
    Set Location = ActiveDocument.Range

    Dim j As Long
    Dim regexp As Object
    Dim Foundmatches As Object
    Set regexp = CreateObject("VBScript.RegExp")

    With regexp
        .Pattern = "([\,]\d*?[1-9])0+$"
        .IgnoreCase = True
        .Global = True

        Set Foundmatches = .Execute(Location.Text)
        For j = Foundmatches.Count - 1 To 0 Step -1
            With ActiveDocument.Range.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Replacement.Font.Hidden = True
                .Text = Foundmatches(j)
                .Replacement.Text = regexp.Replace(Foundmatches(j), "$1")
                .Execute Replace:=wdReplaceAll
            End With
        Next j
    End With
End Sub

Upvotes: 0

Views: 249

Answers (1)

macropod
macropod

Reputation: 13505

You don't need regexp. Try:

Sub DeleteTrailingZeros()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, StrVal As String, i As Long
For Each Tbl In ActiveDocument.Tables
  With Tbl
    Set Rng = .Range
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = ",[0-9]@>"
        .Replacement.Text = ""
        .Execute
      End With
      Do While .Find.Found
        If Not .InRange(Rng) Then Exit Do
        StrVal = .Text
        Do While Right(StrVal, 1) = "0"
          StrVal = Left(StrVal, Len(StrVal) - 1)
        Loop
        If StrVal = "," Then StrVal = ""
        .Text = StrVal
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
  End With
Next Tbl
Application.ScreenUpdating = True
End Sub

or, somewhat simpler:

Sub DeleteTrailingZeros()
Application.ScreenUpdating = False
Dim StrVal As String, i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = ",[0-9]@>"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
    If .Information(wdWithInTable) = True Then
      StrVal = .Text
      Do While Right(StrVal, 1) = "0"
        StrVal = Left(StrVal, Len(StrVal) - 1)
      Loop
      If StrVal = "," Then StrVal = ""
      .Text = StrVal
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Upvotes: 1

Related Questions