Function СУМ_ПРОП$(ByVal ЧИСЛО#)   ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
     Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
     If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
     sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
     des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
     nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
     ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
     RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
     rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
     kop = Right(Format(ЧИСЛО, "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
     СУМ_ПРОП = "(" & UCase(Left(m, 1)) & Mid(m, 2) & " рубл" & IIf(rub \ 10 = 1 Or ((rub + 9) Mod 10) >= 4, "ей ", IIf(rub Mod 10 = 1, "ь ", "я ")) & _
                "" 'kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)"))
End Function

Sub Макрос1()

Dim i, rr, n, nt, nz As Integer, ch, sFigs, sNum As String, FlagRub As Boolean
'
With Selection
' выделяем цифры и допустимые знаки разделения
     .End = .Start
     .MoveStartWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdBackward
     .MoveEndWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdForward
' проверяем выделенное на валидность
     If .End = .Start Then Exit Sub
     sFigs = Replace(Replace(Replace(Replace(Replace(Replace(.Text, " ", ""), Chr(160), ""), Chr(39), ""), Chr(96), ""), Chr(145), ""), Chr(146), "")
     n = Len(sFigs)
     If n = 0 Then Exit Sub
     nz = Len(sFigs) - Len(Replace(sFigs, ",", ""))
     'nt = Len(sFigs) - Len(Replace(sFigs, ".", ""))
     If nz > 1 Then i = MsgBox("Лишние запятые (больше одной)", 64): Exit Sub
     'If nt > 1 Then i = MsgBox("Лишние точки (больше одной)", 64): Exit Sub
     'If nz + nt > 1 Then i = MsgBox("Оставьте в качестве разделителя целой и дробной части либо точку, либо запятую", 64): Exit Sub
     'If n - nz - nt < 1 Then Exit Sub
' убираем текст с цифрами
     .Text = ""
' ищем слово "Руб*"
     .MoveEndWhile "рублейяь. ", wdForward:   FlagRub = False
     sNum = Replace(Replace(Replace(Replace(Replace(.Text, "л", ""), "е", ""), "й", ""), ".", ""), " ", "")
     If sNum = "руб" Then FlagRub = True
' убираем текст с "руб*", чтобы потом вставить "правильный" текст
     .Text = ""
     rr = Int(sFigs) ' преобразование из строки в целое число
     n = sFigs ' преобразование из строки в число
     .Text = " " & Replace(Trim(Format(n, "### ### ### ### ##0")), " ", Chr(160)): .Start = .End
      
     If FlagRub Then .Text = " руб. ": .Start = .End
      
     Dim NNN
     With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = sFigs: End With
     .Text = СУМ_ПРОП(NNN): .Start = .End
     If Not FlagRub Then .Text = ")": Exit Sub
     kop = Right(Format(n, "0.00"), 2): .Start = .End
     .Text = kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)"))
End With

End Sub