Move formatted data in selection from Excel into Word tables

I want to move data from Excel into Word tables. We want to keep the formatting of the existing Word tables and only move the data into each cell. The data involved are dollars (#,###), per shares (#.##), and percentages (#.#%).

In Excel the number can be 80.0% but shows up as 0.8 in Word. When I use the .Text("[0-9].[0-9]") function, it goes into an infinite loop. I need something that either only selects the exact criteria (i.e. #.#) and not a unit more OR when transcribing from Excel, makes numbers like 80.0% show up as 0.80 or 80.0%.

I know about the copy and paste special features, but either the table formatting doesn't match exactly like the original or when linking cell by cell, the refresh takes too long. Have also tried asterisk as wildcard in different places.

I did see something about RegEx that looks like it could potentially help with strict criterias.

Sub Seg1_QTD()  
Dim objExcel As New Excel.Application 
Dim exWb As Excel.Workbook 
Dim ExcelFileName As String 
Dim i As Integer   

ExcelFileName = "LocationHere" 
Set exWb = objExcel.Workbooks.Open("Excel.xlsm", ReadOnly:=True, CorruptLoad:=xlExtractData)  

'Change the # for ActiveDocument.Tables dependent on quarter 
If exWb.Sheets("READ ME").Range("B8") = "Q1" Then 
  i = 2 
Else 
  i = 3  
End If  

'There are other lines, I included one to simplify 
With ActiveDocument.Tables(i) .Cell(5, 3).Range.Text = exWb.Sheets("Segment").Cells(7, 5)  
End With  

exWb.Close SaveChanges:=False  
Set exWb = Nothing   
'===================FORMATTTING==================================  

Dim rngOriginal As Range 
Dim strTemp As String  

Application.ScreenUpdating = False   

'Set range of table 
Set rngOriginal = ActiveDocument.Range( \_ Start:=ActiveDocument.Tables(i).Cell(5, 3).Range.Start, \_ End:=ActiveDocument.Tables(i).Cell(23, 6).Range.End) 

rngOriginal.Select   
With Selection.Find 
.Wrap = wdFindStop 
.ClearFormatting 
.Text = "\[0-9\].\[0-9\]"  
.Replacement.Text = "" 
.Forward = True 
.Format = False 
.MatchCase = False 
.MatchWholeWord = False 
.MatchAllWordForms = False 
.MatchSoundsLike = False 
.MatchWildcards = False   

Do While .Execute 
strTemp = Val(Selection.Range) 
Selection.Range = Format((strTemp), "0.0%")  
Selection.Collapse wdCollapseEnd 
rngOriginal.Select 
Loop 
End With 

i = 0   

End Sub

Solution

Assume the number 0.8 is in a cell within rngOriginal.

Search for the number using .Text = "[0-9].[0-9]" to find the cell containing 0.8. Then update the number 0.8 to 80.0%. The first iteration of the loop is successful.
rngOriginal.Select changes the Selection object.
During the next Do While .Execute run, it searches for numbers from the beginning of rngOriginal.
It locates the 0.0 in 80.0%, the cell is updated with 80.0%% (0.0 => 0.0%), and continues searching...
This results in an infinite loop.

Below code is a sample to locate the number and update with percentage.

Option Explicit
Sub SearchPercent()
Dim rngOriginal As Range
Dim strTemp As String, iEnd As Long
'Set range of table
Set rngOriginal = ActiveDocument.Range( _
    Start:=ActiveDocument.Tables(1).Cell(5, 3).Range.Start, _
    End:=ActiveDocument.Tables(1).Cell(23, 6).Range.End)
    iEnd = rngOriginal.End
    With rngOriginal.Find
        .Wrap = wdFindStop
        .ClearFormatting
        .Text = "[0-9].[0-9]"
        .Replacement.Text = ""
        .Forward = True
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        Do While .Execute
            If rngOriginal.Start > iEnd Then Exit Do
            strTemp = Val(rngOriginal.Text)
            rngOriginal.Text = Format((strTemp), "0.0%")
            rngOriginal.Collapse wdCollapseEnd
        Loop
    End With
End Sub