例如，要处理整个文档：

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

或者仅处理所选范围：

Sub DemoB()
Application.ScreenUpdating = False
Dim Rng As Range
With Selection
  Set Rng = .Range
  .Collapse wdCollapseStart
  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

我认为你的问题是你没有改变范围来反映要搜索的文本。你似乎每次都重置到范围的开始。
下面的代码可能会有所帮助

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

你的代码中最根本的问题是你把循环放在了错误的位置，并且你在每个循环中都把WordRng设置回了开头。在没有任何示例文本的情况下，我用你的问题中的文本来测试。下面的代码应该可以工作：

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