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
        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, "йка)", "йки)"))
    Else: СУМ_ПРОП = "("
    End If
End Function
Sub NumberToText()

    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(Replace(.Text, "л", ""), "е", ""), "й", ""), "я", ""), ".", ""), " ", "")
        If sNum = "руб" Then FlagRub = True
' убираем текст с "руб*", чтобы потом вставить "правильный" текст
        .Text = ""
        rr = Val(sFigs)    ' преобразование из строки в целое число
        n = sFigs    ' преобразование из строки в число
        frm = IIf(CDbl(n) = rr, "### ### ##0", "### ### ##0.00")
        .Text = " " & Replace(Trim(Format(n, frm)), " ", 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
        If kop = "00" Then
             .Text = ") ": Exit Sub
        Else
            
            .Text = IIf(rr, " ", "") & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)")) & " "
        End If
    End With

End Sub