Excel как сумму вывести прописью в соседнюю ячейку?
 

Пожалуйста поделитесь волшебной формулой, или что там.Прошу не посылать по разным ссылкам, пыталась сама искать - ниче не поняла, честно нет времени со всем этим разбираться.Просто научите,кто в курсе, куда нажать и че написать.Спасибо.

0) Открыть книгу. Скопировать то что ниже '--------------

1) Нажать Alt+F11

2) Insert - Module

3) Вставить скопированное

4) В ячейку A1 ввести 123456789, а в любую другую - ввести формулу =СУММА_ПРОП(A1)

'--------------
Option Explicit

'Пользовательская функция СУММА_ПРОПИСЬЮ для применения на рабочем листе.
'Возвращает сумму прописью в указанной валюте.
'Работает для сумм, по модулю меньших квадриллиона. Все другие суммы функция считает нулём.
'Для отрицательных сумм добавляется слово "Минус".
'Первый аргумент "Ячейка" - ссылка на ячейку, содержащую сумму, которую надо отобразить прописью.
'Второй аргумент (необязательный) "Валюта" - строка с кодом валюты. Возможные значения:
'"USD" - доллары,
'"EUR" - евро,
'"RUR", любая другая строка (кроме вышеупомянутых строк) или аргумент пропущен вообще - рубли.
'Третий аргумент (необязательный) "Копейки" - формат вывода копеек. Возможные значения:
'1 - копейки числом,
'2 - копейки числом с лидирующим нулём при необходимости,
'0, любое другое число (кроме вышеупомянутых чисел) или аргумент пропущен вообще - копейки прописью.
Public Function СУММА_ПРОП(ByVal Ячейка As Range, Optional ByVal Валюта As String = "RUR", Optional ByVal Копейки As Integer = 0) As String
If Ячейка.Count <> 1 Then
СУММА_ПРОП = "Первый аргумент функции ""СУММАПРОПИСЬЮ"" должен содержать ссылку на диапазон, занимающий одну ячейку!"
Exit Function
End If
СУММА_ПРОП = SumInWords(Ячейка.Value, Валюта, Копейки)
End Function

'Функция возвращает сумму прописью в указанной валюте.
'Первый аргумент - число (сумма).
'Второй аргумент - валюта. "USD" - доллары, "EUR" - евро, любая другая строка - рубли.
'Третий аргумент - формат вывода копеек:
'1 - копейки числом,
'2 - копейки числом с лидирующим нулём при необходимости,
'любое другое число - копейки прописью.
Private Function SumInWords(ByVal Arg As Double, ByVal Curr As String, ByVal Kop As Integer) As String
If Not IsNumeric(Arg) Then
SumInWords = ""
Exit Function
End If
'Округление до двух знаков после запятой
Arg = Round(Arg, 2)

'Будущий результат (возврат) этой функции
Dim Result As String
Result = ""

'Для отрицательных чисел
If Arg < 0 Then
Result = Result & "Минус "
End If
Arg = Abs(Arg)

'Целая часть числа
Dim Whole As Double
Whole = Fix(Arg)
Result = Result & ToQuadrillion(Whole)

'Добавление наименования валюты
If Curr = "USD" Then
Result = Result & Dollar(Whole)
ElseIf Curr = "EUR" Then
Result = Result & " евро"
Else
Result = Result & Rouble(Whole)
End If

'Вывод копеек
Dim Fraction As Integer
Fraction = (Arg - Whole) * 100
If Kop = 1 Then
Result = Result & " " & Fraction
ElseIf Kop = 2 Then
Result = Result & " " & Right("0" & Fraction, 2)
Else
If Curr = "EUR" Or Curr = "USD" Then 'центы мужского рода
Result = Result & " " & ToThousand(Fraction, True)
Else 'копейки женского рода - 'ША убрал копейки нахрен!
Result = Result '& " " & ToThousand(Fraction, False)


End If
End If

'Добавление наименования копеек валюты
If Curr = "USD" Then
Result = Result & Cent(Fraction)
ElseIf Curr = "EUR" Then
Result = Result & Cent(Fraction)
Else
'ША убрал копейки Result = Result & Kopeck(Fraction)
End If

'С заглавной буквы
Result = UCase(Left(Result, 1)) & Right(Result, Len(Result) - 1)
'Точка - ША убрал
'Result = Result & "."

SumInWords = Result
End Function

'Функция возвращает слово "цент" в нужной форме в зависимости от окончания числа.
Private Function Cent(ByVal Arg As Double) As String
'Единицы (один последний знак)
Dim Unitys As Integer
Unitys = Arg - Fix(Arg / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Arg - Fix(Arg / 100) * 100
If Tens > 10 And Tens < 20 Then
Cent = " центов"
Else
Select Case Unitys
Case 1
Cent = " цент"
Case 2, 3, 4
Cent = " цента"
Case Else
Cent = " центов"
End Select
End If
End Function

'Функция возвращает слово "копейка" в нужной форме в зависимости от окончания числа.
Private Function Kopeck(ByVal Arg As Double) As String
'Единицы (один последний знак)
Dim Unitys As Integer
Unitys = Arg - Fix(Arg / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Arg - Fix(Arg / 100) * 100
If Tens > 10 And Tens < 20 Then
Kopeck = " копеек"
Else
Select Case Unitys
Case 1
Kopeck = " копейка"
Case 2, 3, 4
Kopeck = " копейки"
Case Else
Kopeck = " копеек"
End Select
End If
End Function

'Функция возвращает слово "доллар" в нужной форме в зависимости от окончания числа.
Private Function Dollar(ByVal Arg As Double) As String
'Единицы (один последний знак)
Dim Unitys As Integer
Unitys = Arg - Fix(Arg / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Arg - Fix(Arg / 100) * 100
If Tens > 10 And Tens < 20 Then
Dollar = " долларов"
Else
Select Case Unitys
Case 1
Dollar = " доллар"
Case 2, 3, 4
Dollar = " доллара"
Case Else
Dollar = " долларов"
End Select
End If
End Function

'Функция возвращает слово "рубль" в нужной форме в зависимости от окончания числа.
Private Function Rouble(ByVal Arg As Double) As String
'Единицы (один последний знак)
Dim Unitys As Integer
Unitys = Arg - Fix(Arg / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Arg - Fix(Arg / 100) * 100
If Tens > 10 And Tens < 20 Then
Rouble = " рублей"
Else
Select Case Unitys
Case 1
Rouble = " рубль"
Case 2, 3, 4
Rouble = " рубля"
Case Else
Rouble = " рублей"
End Select
End If
End Function

'Функция возвращает число прописью.
'Аргумент - целое положительное число, меньшее квадриллиона.
Private Function ToQuadrillion(ByVal Arg As Double) As String
Arg = Abs(Fix(Arg))
If Arg <= 0 Or Arg > 999999999999999# Then
ToQuadrillion = "ноль"
Exit Function
End If

'Будущий результат (возврат) этой функции
Dim Result As String
Result = ""

'Триллионы в переданномм числе
Dim Trillions As Long
Trillions = Fix(Arg / 1000000000000#)
If Trillions > 0 Then
Result = ToTrillion(Trillions)
'Единицы
Dim Unitys As Integer
Unitys = Trillions - Fix(Trillions / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Trillions - Fix(Trillions / 100) * 100
If Tens > 10 And Tens < 20 Then
Result = Result & " триллионов "
Else
Select Case Unitys
Case 1
Result = Result & " триллион "
Case 2, 3, 4
Result = Result & " триллиона "
Case Else
Result = Result & " триллионов "
End Select
End If
End If

'Оставшаяся часть числа
Dim Rest As Double
Rest = Arg - Trillions * 1000000000000#
If Rest > 0 Then
Result = Result & ToTrillion(Rest)
End If

ToQuadrillion = Trim(Result)
End Function

'Функция возвращает число прописью.
'Аргумент - целое положительное число, меньшее триллиона.
Private Function ToTrillion(ByVal Arg As Double) As String
Arg = Abs(Fix(Arg))
If Arg <= 0 Or Arg > 999999999999# Then
ToTrillion = "ноль"
Exit Function
End If

'Будущий результат (возврат) этой функции
Dim Result As String
Result = ""

'Миллиарды в переданномм числе
Dim Milliards As Long
Milliards = Fix(Arg / 1000000000)
If Milliards > 0 Then
Result = ToMilliard(Milliards)
'Единицы
Dim Unitys As Integer
Unitys = Milliards - Fix(Milliards / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Milliards - Fix(Milliards / 100) * 100
If Tens > 10 And Tens < 20 Then
Result = Result & " миллиардов "
Else
Select Case Unitys
Case 1
Result = Result & " миллиард "
Case 2, 3, 4
Result = Result & " миллиарда "
Case Else
Result = Result & " миллиардов "
End Select
End If
End If

'Оставшаяся часть числа
Dim Rest As Long
Rest = Arg - Milliards * 1000000000#
If Rest > 0 Then
Result = Result & ToMilliard(Rest)
End If

ToTrillion = Trim(Result)
End Function

' продолжение
'Функция возвращает число прописью.
'Аргумент - целое положительное число, меньшее миллиарда.
Private Function ToMilliard(ByVal Arg As Long) As String
Arg = Abs(Arg)
If Arg <= 0 Or Arg > 999999999 Then
ToMilliard = "ноль"
Exit Function
End If

'Будущий результат (возврат) этой функции
Dim Result As String
Result = ""

'Миллионы в переданномм числе
Dim Millions As Long
Millions = Fix(Arg / 1000000)
If Millions > 0 Then
Result = ToMillion(Millions)
'Единицы
Dim Unitys As Integer
Unitys = Millions - Fix(Millions / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Millions - Fix(Millions / 100) * 100
If Tens > 10 And Tens < 20 Then
Result = Result & " миллионов "
Else
Select Case Unitys
Case 1
Result = Result & " миллион "
Case 2, 3, 4
Result = Result & " миллиона "
Case Else
Result = Result & " миллионов "
End Select
End If
End If

'Оставшаяся часть числа
Dim Rest As Long
Rest = Arg - Millions * 1000000
If Rest > 0 Then
Result = Result & ToMillion(Rest)
End If

ToMilliard = Trim(Result)
End Function

'Функция возвращает число прописью.
'Аргумент - целое положительное число, меньшее миллиона.
Private Function ToMillion(ByVal Arg As Long) As String
Arg = Abs(Arg)
If Arg <= 0 Or Arg > 999999 Then
ToMillion = "ноль"
Exit Function
End If

'Будущий результат (возврат) этой функции
Dim Result As String
Result = ""

'Тысячи в переданномм числе
Dim Thousands As Long
Thousands = Fix(Arg / 1000)
If Thousands > 0 Then
Result = ToThousand(Thousands, False)
'Единицы
Dim Unitys As Integer
Unitys = Thousands - Fix(Thousands / 10) * 10
'Десятки (два последних знака)
Dim Tens As Integer
Tens = Thousands - Fix(Thousands / 100) * 100
If Tens > 10 And Tens < 20 Then
Result = Result & " тысяч "
Else
Select Case Unitys
Case 1
Result = Result & " тысяча "
Case 2, 3, 4
Result = Result & " тысячи "
Case Else
Result = Result & " тысяч "
End Select
End If
End If

'Оставшаяся часть числа
Dim Rest As Long
Rest = Arg - Thousands * 1000
If Rest > 0 Then
Result = Result & ToThousand(Rest, True)
End If

ToMillion = Trim(Result)
End Function

'Функция возвращает число прописью.
'Первый аргумент - целое положительное число, меньшее тысячи.
'Второй аргумент - род числа (True - мужской, False - женский, для тысяч).
Private Function ToThousand(ByVal Arg As Long, ByVal Gender As Boolean) As String
Arg = Abs(Arg)
If Arg <= 0 Or Arg > 999 Then
ToThousand = "ноль"
Exit Function
End If

'Будущий результат (возврат) этой функции
Dim Result As String

'Сотни в переданномм числе
Dim Hundreds As Integer
Hundreds = Fix(Arg / 100) * 100
Select Case Hundreds
Case 100
Result = "сто "
Case 200
Result = "двести "
Case 300
Result = "триста "
Case 400
Result = "четыреста "
Case 500
Result = "пятьсот "
Case 600
Result = "шестьсот "
Case 700
Result = "семьсот "
Case 800
Result = "восемьсот "
Case 900
Result = "девятьсот "
End Select

'Оставшаяся часть числа (за вычетом сотен)
Dim Rest As Integer
Rest = Arg - Hundreds
If Rest < 20 Then
Select Case Rest
Case 1
If Gender Then
Result = Result & "один"
Else
Result = Result & "одна"
End If
Case 2
If Gender Then
Result = Result & "два"
Else
Result = Result & "две"
End If
Case 3
Result = Result & "три"
Case 4
Result = Result & "четыре"
Case 5
Result = Result & "пять"
Case 6
Result = Result & "шесть"
Case 7
Result = Result & "семь"
Case 8
Result = Result & "восемь"
Case 9
Result = Result & "девять"
Case 10
Result = Result & "десять"
Case 11
Result = Result & "одиннадцать"
Case 12
Result = Result & "двенадцать"
Case 13
Result = Result & "тринадцать"
Case 14
Result = Result & "четырнадцать"
Case 15
Result = Result & "пятнадцать"
Case 16
Result = Result & "шестнадцать"
Case 17
Result = Result & "семнадцать"
Case 18
Result = Result & "восемнадцать"
Case 19
Result = Result & "девятнадцать"
End Select
ToThousand = Trim(Result)
Exit Function
'Если оставшаяся часть числа (за вычетом сотен) = 20 и больше
Else
'Десятки в переданном числе
Dim Tens As Integer
Tens = Fix(Rest / 10) * 10
Select Case Tens
Case 20
Result = Result & "двадцать "
Case 30
Result = Result & "тридцать "
Case 40
Result = Result & "сорок "
Case 50
Result = Result & "пятьдесят "
Case 60
Result = Result & "шестьдесят "
Case 70
Result = Result & "семьдесят "
Case 80
Result = Result & "восемьдесят "
Case 90
Result = Result & "девяносто "
End Select
'Единицы в переданном числе
Dim Unitys As Integer
Unitys = Rest - Tens
Select Case Unitys
Case 1
If Gender Then
Result = Result & "один"
Else
Result = Result & "одна"
End If
Case 2
If Gender Then
Result = Result & "два"
Else
Result = Result & "две"
End If
Case 3
Result = Result & "три"
Case 4
Result = Result & "четыре"
Case 5
Result = Result & "пять"
Case 6
Result = Result & "шесть"
Case 7
Result = Result & "семь"
Case 8
Result = Result & "восемь"
Case 9
Result = Result & "девять"
End Select
ToThousand = Trim(Result)
End If
End Function

Также необходимо убедиться, что Макросы включены, иначе формула не сработает. В Excel 2007/2010 включить макросы непросто - нужно внимательно смотреть на сообщение вверху окна программы после переоткрытия файла, открыть Центр безопасности и там РАЗРЕШИТЬ все что можно.

3-economist > Преспасибо вам огромное! Заработала функция. Только копейки не пишет. Как их сделать? фин.документ - они нужны.Спасибо.

в теле есть модуля имеется такая фраза:
[b]Else 'копейки женского рода - 'ША убрал копейки нахрен![/b]
поэтому и не выдает)))

CheSteR1 и Carcass - виноватюсь, облажался. Считать приходится в тысячах и миллионах, копейки и правда - не люблю...

В общем, надо изменить строки:

'ША убрал копейки Result = Result & Kopeck(Fraction)

на

Result = Result & Kopeck(Fraction)

и

'Точка - ША убрал
'Result = Result & "."

заменить на

'Точка - ША убрал
Result = Result & "."
'Все получится!

6-economist >Ну вы видать масштабный товарисч, мелочами не заморачиваетесь. Спасибо, завтра попробую на работе.
5-Carcass >Спасибо и вам. Честно говоря думала про "Ша" какойта прикол,завтра почитаю где эта ША.
Спасибо!

5-Carcass >
и это тоже на что-то заменять? Слово "копеек" пишет, 20 не рисует!
6-economist >Товарищ мильенщик, подскажите пожалуйста.)

Подскажу так.
Else 'копейки женского рода - 'ША убрал копейки нахрен!
Result = Result [u]'[/u]& " " & ToThousand(Fraction, False)
Уберите здесь подчеркнутый апостроф.
----
Else
[u]'ША убрал копейки [/u]Result = Result & Kopeck(Fraction)
End If
Уберите здесь все, что подчеркнуто.

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

9-g_krd > нет ничего подчеркнутого

CheSteR1 - подчеркнутое не в моем коде нужно искать, а в посте №9 - и это подстрока 'ША убрал копейки

CheSteR1 - если вы хотите видеть сайты/форумы так как их видят их создатели (со всем форматированием, подчеркиваением и тп) - используйте надежные браузеры типа FireFox. Конечно же, в нем нельзя запрещать использование шрифтов, подавление форматов итп. То есть как есть из коробки. И все будет хорошо...

Просто СУПЕР! Спасибо огромное, economist!

AUX - Завсегда пожалуйста, обращайтесь! По хорошему такие функции нужно не плодить как тараканов в XLS-файлах, а сохранять в единственном числе - на сетевом диске/сервере организации в виде так называемой "Надстройки" XLA или XLAM и использовать совместно всем сотрудникам, один раз настроив каждый Excel (подключив надстройку). В моей рабочей надстройке - несколько десятков полезных функций и более 200 макросов, включая такие как набор номера на модеме, хирургию 1С-отчетов, перевод текста русанг/ангрус итп, из которых только половина самописных, все остальное чудесно стыбзено с ресурсов типа planetaexcel, cpearsonб excel-vba, officeextention итд, как и эта сумма прописью.
...
Excel с VBA (так же как, собсвенно, как и свободный и бесплатный OpenOffice Calc со своим языком StarBasic) - позволяют решить абсолютно ЛЮБУЮ задачу автоматизации с помощью сил самих пользователей, ну или с легкой помощью программистов. К сожалению, большинство программистов - язык макросов VBA не считают чем-то серьезным и сами крайне неохотно неохотно его изучают. Поэтому Интернет и форумы остаются лучшими помощниками в изучении макросов.