Text:="=" & Replace(.Range.Text, " ", "") & " \*CardText"

Sub SumPropWord()
    Dim aa#
    With Selection
        aa = CDbl(Replace(Replace(.Range.Text, Chr(160), ""), " ", ""))
        .Range.Text = .Range.Text & " " & MSumProp(aa)
    End With
End Sub
Function MSumProp$(chislo#) 'Автор MCH (Михаил Ч.), май 2012
Dim rub$, kop$, ed, des, sot, nadc, razr, i&, m$
If chislo >= 1E+15 Or chislo < 0 Then Exit Function

sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
razr = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "рубль ", "рубля ", "рублей ")

rub = Left(Format(chislo, "000000000000000.00"), 15)
kop = Right(Format(chislo, "0.00"), 2)

If CDbl(rub) = 0 Then m = "ноль "
For i = 1 To Len(rub) Step 3
    If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
        m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, razr(i + 1), IIf(Mid(rub, i + 2, 1) = "1", razr(i - 1), razr(i)))
    End If
Next i
MSumProp = UCase(Left(m, 1)) & Mid(m, 2) & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек", IIf(kop Mod 10 = 1, "йка", "йки"))
End Function


Public Sub test3()
    Dim pReg As Object
    Dim numField As Field
    Dim numText As String
        
    If Selection.Characters.Count > 1 Then
        Set pReg = CreateObject("VBScript.RegExp")
        pReg.Global = True: pReg.Pattern = "[^\d]+"
        numText = pReg.Replace(Selection.Text, "")
        If Len(numText) > 0 Then
            Selection.MoveRight Count:=1
            Selection.TypeText " "
            Set numField = Selection.Fields.Add(Selection.Range, wdFieldEmpty, "=" & numText & "\*CardText", False)
            numField.Update
        End If
    End If
End Sub


With Selection
    .MoveStartWhile "0123456789 " & Chr(160), wdBackward
    .MoveEndWhile "0123456789 " & Chr(160), wdForward
    nValue1 = Val(Replace(Replace(.Text, " ", ""), Chr(160), ""))
    
    nShift = .MoveEndWhile("0123456789.,-=", wdForward)
    nValue2 = IIf(nShift > 0, Val(Right(.Text, nShift - 1)), 0)
    .Start = .End
    .TypeText " ("
    .Fields.Add .Range, wdFieldEmpty, "=" & nValue1 & " \* CardText \* FirstCap", True
    .TypeText " руб. " & Format(nValue2, "00") & " коп.)"
End With

nValue2 = IIf(nShift > 0, Val(Right(.Text, nShift - 1)), 0)

Sub Прописью()   'цифры из выделенного текста перевести в число прописью
    Dim NNN
    With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
    If Len(NNN) Then Selection.MoveRight Unit:=wdWord: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
End Sub


NNN = CDbl(...

Dim NNN#

     nValue2 = 0
    If nShift > 1 Then nValue2 = Val(Right(.Text, nShift - 1))


NNN = IIf(Err, Err.Description, СУМ_ПРОП(NNN)