Как прописать сумму, число, цифры прописью в Excel

Очень распространенная задача написать числа прописью в Excel. Встроенной функции пока еще в Excel нет, поэтому мы можем создать пользовательскую функцию, которая и будет заменять цифры, числа текстом.

Как правило, это требуется в торговле, бухгалтерском учете и других сферах, где производятся расчеты с денежными средствами. Обычно необходимо перевести сумму в рублях и копейках прописью, как на картинке (первый пример).

Смотрите также: Как написать сумму прописью на украинском языке

Сумма в рублях, долларах или евро с копейками прописью

Допустим, мы делаем какие-то расчеты в таблице и получаем итоговую сумму в рублях 1526,23

Нам необходимо прописать эту цифру в рублях и желательно указать так же и копейки. Для этого создадим специальную универсальную пользовательскую функцию, которая будет выглядеть следующим образом

Propis(Amount;Money;lang;Prec)

где

Amount – это ссылка на ячейку с числом

Money – тут указывается вид валюты, можно указать рубли, доллары и евро (“RUB”, “USD”, “EUR”) – валюта обязательно указывается в кавычках.

lang – это язык на котором необходимо вывести сумму, доступно два языка английский и русский (“EN”, “RU”) – так же указываем в кавычках

Prec – показывать (1) или не показывать (0) дробную часть

Таким образом, вы сможете прописать сумму в рублях, долларах или евро прописью русскими или английскими буквами вместе с дробной частью, при этом в зависимости от числа будет вставляться правильное окончание, например 2 рубля, 8 рублей, 1 рубль и так далее.

Чтобы создать пользовательскую функцию Propis, необходимо скопировать код, указанный ниже, далее нажмите ALT+F11, чтобы открыть VBA, добавьте новый пустой модуль через меню Insert – Module и вставьте туда скопированный код

Макрос пользовательской функции суммы прописью

Function Propis(Amount As String, Optional Money As String = "RUB", Optional lang As String = "RU", Optional Prec As Integer = 1)
 Dim whole As Double

 Amount = Replace(Amount, "-", Application.International(xlDecimalSeparator))
 Amount = Replace(Amount, ".", Application.International(xlDecimalSeparator))
 Amount = Replace(Amount, ",", Application.International(xlDecimalSeparator))

 Sum = WorksheetFunction.Round(CDbl(Amount), 2)
 Money = UCase(Money)
 lang = UCase(lang)
 whole = Int(Sum)
 fraq = Format(Round((Sum - whole) * 100), "00")

 Select Case Class(whole, 1) + Class(whole, 2) * 10
 Case 1, 21, 31, 41, 51, 61, 71, 81, 91
 w_rus_r = "рубль"
 w_rus_d = "доллар"
 w_rus_e = "евро"
 w_en_r = "rubles"
 w_en_d = "dollars"
 w_en_e = "euro"

 Case 2, 3, 4, 22, 23, 24, 32, 33, 34, 42, 43, 44, 52, 53, 54, 62, 63, 64, 72, 73, 74, 82, 83, 84, 92, 93, 94
 w_rus_r = "рубля"
 w_rus_d = "доллара"
 w_rus_e = "евро"
 w_en_r = "rubles"
 w_en_d = "dollars"
 w_en_e = "euro"

 Case Else
 w_rus_r = "рублей"
 w_rus_d = "долларов"
 w_rus_e = "евро"
 w_en_r = "rubles"
 w_en_d = "dollars"
 w_en_e = "euro"

 End Select

 Select Case fraq
 Case 1, 21, 31, 41, 51, 61, 71, 81, 91
 f_rus_r = "копейка"
 f_rus_d = "цент"
 f_rus_e = "цент"
 f_rus_p = "сотая"
 f_en_r = "kopecks"
 f_en_d = "cents"
 f_en_e = "cents"
 f_en_e = "cents"

 Case 2, 3, 4, 22, 23, 24, 32, 33, 34, 42, 43, 44, 52, 53, 54, 62, 63, 64, 72, 73, 74, 82, 83, 84, 92, 93, 94
 f_rus_r = "копейки"
 f_rus_d = "цента"
 f_rus_e = "цента"
 f_en_r = "kopecks"
 f_en_d = "cents"
 f_en_e = "cents"
 Case Else
 f_rus_r = "копеек"
 f_rus_d = "центов"
 f_rus_e = "центов"
 f_en_r = "kopecks"
 f_en_d = "cents"
 f_en_e = "cents"
 End Select

 If Prec = 0 Then
 fraq = ""
 f_rus_r = ""
 f_rus_d = ""
 f_rus_e = ""
 f_en_r = ""
 f_en_d = ""
 f_en_e = ""
 End If

 If lang = "RU" Then
 Select Case Money
 Case "RUB"
 Out = ScriptRus(whole) & " " & w_rus_r & " " & fraq & " " & f_rus_r
 Case "USD"
 Out = ScriptRus(whole) & " " & w_rus_d & " " & fraq & " " & f_rus_d
 Case "EUR"
 Out = ScriptRus(whole) & " " & w_rus_e & " " & fraq & " " & f_rus_e
 End Select
 End If

 If lang = "EN" Then
 Select Case Money
 Case "RUB"
 Out = ScriptEng(whole) & " " & w_en_r & " " & fraq & " " & f_en_r
 Case "USD"
 Out = ScriptEng(whole) & " " & w_en_d & " " & fraq & " " & f_en_d
 Case "EUR"
 Out = ScriptEng(whole) & " " & w_en_e & " " & fraq & " " & f_en_e
 End Select
 End If

 Propis = WorksheetFunction.Trim(Out)

End Function

Private Function Class(m, i)
 Class = Int(Int(m - (10 ^ i) * Int(m / (10 ^ i))) / 10 ^ (i - 1))
End Function

Private Function ScriptRus(n As Double) As String
 Dim Nums1, Nums2, Nums3, Nums4 As Variant
 Nums1 = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 Nums2 = Array("", "десять ", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
 Nums3 = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
 Nums4 = Array("", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 Nums5 = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")

 If n = 0 Then
 ScriptRus = "Ноль"
 Exit Function
 End If
 ed = Class(n, 1)
 dec = Class(n, 2)
 sot = Class(n, 3)
 tys = Class(n, 4)
 dectys = Class(n, 5)
 sottys = Class(n, 6)
 mil = Class(n, 7)
 decmil = Class(n, 8)
 sotmil = Class(n, 9)
 mlrd = Class(n, 10)

 If mlrd > 0 Then
 Select Case mlrd
 Case 1
 mlrd_txt = Nums1(mlrd) & "миллиард "
 Case 2, 3, 4
 mlrd_txt = Nums1(mlrd) & "миллиарда "
 Case 5 To 20
 mlrd_txt = Nums1(mlrd) & "миллиардов "
 End Select
 End If
 If (sotmil + decmil + mil) > 0 Then
 sotmil_txt = Nums3(sotmil)

 Select Case decmil
 Case 1
 mil_txt = Nums5(mil) & "миллионов "
 GoTo www
 Case 2 To 9
 decmil_txt = Nums2(decmil)
 End Select

 Select Case mil
 Case 1
 mil_txt = Nums1(mil) & "миллион "
 Case 2, 3, 4
 mil_txt = Nums1(mil) & "миллиона "
 Case 0, 5 To 20
 mil_txt = Nums1(mil) & "миллионов "
 End Select
 End If
www:
 sottys_txt = Nums3(sottys)
 Select Case dectys
 Case 1
 tys_txt = Nums5(tys) & "тысяч "
 GoTo eee
 Case 2 To 9
 dectys_txt = Nums2(dectys)
 End Select

 Select Case tys
 Case 0
 If dectys > 0 Then tys_txt = Nums4(tys) & "тысяч "
 Case 1
 tys_txt = Nums4(tys) & "тысяча "
 Case 2, 3, 4
 tys_txt = Nums4(tys) & "тысячи "
 Case 5 To 9
 tys_txt = Nums4(tys) & "тысяч "
 End Select
 If dectys = 0 And tys = 0 And sottys <> 0 Then sottys_txt = sottys_txt & " тысяч "
eee:
 sot_txt = Nums3(sot)

 Select Case dec
 Case 1
 ed_txt = Nums5(ed)
 GoTo rrr
 Case 2 To 9
 dec_txt = Nums2(dec)
 End Select

 ed_txt = Nums1(ed)
rrr:

 ScriptRus = mlrd_txt & sotmil_txt & decmil_txt & mil_txt & sottys_txt & dectys_txt & tys_txt & sot_txt & dec_txt & ed_txt
 ScriptRus = UCase(Left(ScriptRus, 1)) & LCase(Mid(ScriptRus, 2, Len(ScriptRus) - 1))
 End Function

Private Function ScriptEng(ByVal Number As Double)
 Dim BigDenom As String, Temp As String
 Dim Count As Integer

 ReDim Place(9) As String
 Place(2) = " Thousand "
 Place(3) = " Million "
 Place(4) = " Billion "
 Place(5) = " Trillion "

 strAmount = Trim(Str(Int(Number)))

 Count = 1
 Do While strAmount <> ""
 Temp = GetHundreds(Right(strAmount, 3))
 If Temp <> "" Then BigDenom = Temp & Place(Count) & BigDenom
 If Len(strAmount) > 3 Then
 strAmount = Left(strAmount, Len(strAmount) - 3)
 Else
 strAmount = ""
 End If
 Count = Count + 1
 Loop
 Select Case BigDenom
 Case ""
 BigDenom = "Zero "
 Case "One"
 BigDenom = "One "
 Case Else
 BigDenom = BigDenom & " "
 End Select
 ScriptEng = BigDenom

End Function

Private Function GetHundreds(ByVal MyNumber)
 Dim result As String
 If Val(MyNumber) = 0 Then Exit Function
 MyNumber = Right("000" & MyNumber, 3)

 If Mid(MyNumber, 1, 1) <> "0" Then
 result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
 End If

 If Mid(MyNumber, 1, 1) <> "0" And (Mid(MyNumber, 2, 1) <> "0" Or Mid(MyNumber, 3, 1) <> "0") Then
 result = result & "And "
 End If

 If Mid(MyNumber, 2, 1) <> "0" Then
 result = result & GetTens(Mid(MyNumber, 2))
 Else
 result = result & GetDigit(Mid(MyNumber, 3))
 End If
 GetHundreds = result
End Function
Private Function GetTens(TensText)
 Dim result As String
 result = ""
 If Val(Left(TensText, 1)) = 1 Then
 Select Case Val(TensText)
 Case 10: result = "Ten"
 Case 11: result = "Eleven"
 Case 12: result = "Twelve"
 Case 13: result = "Thirteen"
 Case 14: result = "Fourteen"
 Case 15: result = "Fifteen"
 Case 16: result = "Sixteen"
 Case 17: result = "Seventeen"
 Case 18: result = "Eighteen"
 Case 19: result = "Nineteen"
 Case Else
 End Select
 Else
 Select Case Val(Left(TensText, 1))
 Case 2: result = "Twenty "
 Case 3: result = "Thirty "
 Case 4: result = "Forty "
 Case 5: result = "Fifty "
 Case 6: result = "Sixty "
 Case 7: result = "Seventy "
 Case 8: result = "Eighty "
 Case 9: result = "Ninety "
 Case Else
 End Select
 result = result & GetDigit _
 (Right(TensText, 1))
 End If
 GetTens = result
End Function
Private Function GetDigit(Digit)
 Select Case Val(Digit)
 Case 1: GetDigit = "One"
 Case 2: GetDigit = "Two"
 Case 3: GetDigit = "Three"
 Case 4: GetDigit = "Four"
 Case 5: GetDigit = "Five"
 Case 6: GetDigit = "Six"
 Case 7: GetDigit = "Seven"
 Case 8: GetDigit = "Eight"
 Case 9: GetDigit = "Nine"
 Case Else: GetDigit = ""
 End Select
End Function

Итак, функция создана, чтобы воспользоваться ей, просто введите ячейке Propis с нужными аргументами, например, если нам необходимо прописать сумму прописью в рублях с копейками и на русском языке, то формула будет выглядеть следующим образом.

=Propis(B2;"RUB";"RU";1)

Числа прописью с копейками  заглавными или строчными буквами в Excel

Вот код VBA для пользовательской функции. Отображение суммы прописью с копейками и выбором первой заглавной или строчной буквы

Function РубПропись(Сумма As Double, Optional Без_копеек As Boolean = False, _
 Optional КопПрописью As Boolean = False, Optional начинитьПрописной As Boolean = True) As String
'Функция для написания суммы прописью
 Dim ed, des, sot, ten, razr, dec
 Dim i As Integer, str As String, s As String
 Dim intPart As String, frPart As String
 Dim mlnEnd, tscEnd, razrEnd, rub, cop
 
 dec = Array("", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ten = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
 des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
 sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
 razr = Array("", "тысяч", "миллион", "миллиард")
 mlnEnd = Array("ов ", " ", "а ", "а ", "а ", "ов ", "ов ", "ов ", "ов ", "ов ")
 tscEnd = Array(" ", "а ", "и ", "и ", "и ", " ", " ", " ", " ", " ")
 razrEnd = Array(mlnEnd, mlnEnd, tscEnd, "")
 rub = Array("рублей", "рубль", "рубля", "рубля", "рубля", "рублей", "рублей", "рублей", "рублей", "рублей")
 cop = Array("копеек", "копейка", "копейки", "копейки", "копейки", "копеек", "копеек", "копеек", "копеек", "копеек")
 If Сумма >= 1000000000000# Or Сумма < 0 Then РубПропись = CVErr(xlErrValue): Exit Function
 '&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
 If Round(Сумма, 2) >= 1 Then
 intPart = Left$(Format(Сумма, "000000000000.00"), 12)
 For i = 0 To 3
 s = Mid$(intPart, i * 3 + 1, 3)
 If s <> "000" Then
 str = str & sot(CInt(Left$(s, 1)))
 If Mid$(s, 2, 1) = "1" Then
 str = str & ten(CInt(Right$(s, 1)))
 Else
 str = str & des(CInt(Mid$(s, 2, 1))) & IIf(i = 2, dec(CInt(Right$(s, 1))), ed(CInt(Right$(s, 1))))
 End If
 On Error Resume Next
 str = str & IIf(Mid$(s, 2, 1) = "1", razr(3 - i) & razrEnd(i)(0), _
 razr(3 - i) & razrEnd(i)(CInt(Right$(s, 1))))
 On Error GoTo 0
 End If
 Next i
 str = str & IIf(Mid$(s, 2, 1) = "1", rub(0), rub(CInt(Right$(s, 1))))
 End If
 РубПропись = str
 ''''''''''''''''''
 If Без_копеек = False Then
 frPart = Right$(Format(Сумма, "0.00"), 2)
 If frPart = "00" Then
 frPart = ""
 Else
 If КопПрописью Then
 frPart = IIf(Left$(frPart, 1) = "1", ten(CInt(Right$(frPart, 1))) & cop(0), _
 des(CInt(Left$(frPart, 1))) & dec(CInt(Right$(frPart, 1))) & cop(CInt(Right$(frPart, 1))))
 Else
 frPart = IIf(Left$(frPart, 1) = "1", frPart & " " & cop(0), frPart & " " & cop(CInt(Right$(frPart, 1))))
 End If
 End If
 РубПропись = str & " " & frPart
 End If
 ''''''''''''''''''
' РубПропись = str & frPart
 If начинитьПрописной Then Mid$(РубПропись, 1, 1) = UCase(Mid$(РубПропись, 1, 1))
' If начинитьПрописной Then РубПропись = UCase(Left(РубПропись, 1)) & Mid(РубПропись, 2)
End Function

• Без копеек (1), с копейками (0)
• Копейки прописью (1), числом (0)
• Начинать прописью (0), заглавной (1)

Вот как используется функция

Примечание

• Данная функция будет работать с числами от 0 до 99 999 999
• Перед копирование кода переключите раскладку клавиатуры на русский язык (для корректного копирования русского текста)
• Код VBA необходимо вставлять во все файлы (Книги Excel), где вы хотите, чтобы она работала
• После вставки код, необходимо сохранить файл с поддержкой макросов xlsm (в Excel, начиная с 2007 версии)
• Функцию можно либо набирать в ручную, либо, если вы забыли как она пишется, через мастер функций (кнопка fx в строке формул, категория Определенные пользователем)