Версия для слабовидящих Версия для слабовидящих
Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 58970
Главная » Готовые решения » VBA » Пользовательские функции

Перевод чисел в текст 2 (сумма прописью)
11.11.2014, 21:19
[ Файл-пример (34.5 Kb) ]
  1. 'Сумма Прописью по Владимиру Яркову (короткая)  
  2. 'Владимир Ярков  
  3. 'Функция вывода суммы прописью в рублях и цифрами в копейках  
  4. 'синтаксис: fSUMprop(число[,вариант])  
  5. 'знак числа не учитывается  
  6. 'первый аргумент - число (Variant) до 10 триллионов  
  7. 'второй аргумент =0 - возвращает сумму с первой прописной,  
  8. ' остальные - строчными буквами  
  9. ' <>0 возвращает сумму строчными буквами  
  10. Public Function fSUMprop(xsu As VariantOptional mb As ByteAs String  
  11. On Error GoTo ersupr  
  12. If Not IsNumeric(xsu) Then  
  13.  fSUMprop = ""  
  14.  Exit Function  
  15. End If  
  16. If xsu >= 10000000000000# Then  
  17.  fSUMprop = "слишком большое число"  
  18.  Exit Function  
  19. End If  
  20. Dim ssu As String, nsu, edi, des, sot, ind As Byte, i As Integer  
  21. If Fix(xsu) = 0 Then  
  22.  fSUMprop = "ноль рублей "  
  23. Else  
  24.  ssu = Mid$(Str$(Fix(xsu)), 2) ' строка рублей без знака  
  25.  nsu = (Len(ssu) + 2) \ 3 ' количество троек цифр  
  26.  ssu = Right$("00", nsu * 3 - Len(ssu)) + ssu ' добавляем нулями  
  27.  For i = nsu To 1 Step -1  
  28.  sot = Val(Mid$(ssu, (nsu - i) * 3 + 1, 1)) ' сотни  
  29.  des = Val(Mid$(ssu, (nsu - i) * 3 + 2, 1)) ' десятки  
  30.  edi = Val(Mid$(ssu, (nsu - i) * 3 + 3, 1)) ' единицы  
  31.  If sot + des + edi > 0 Or i = 1 Then  
  32.  If sot > 0 Then  
  33.  fSUMprop = fSUMprop + Choose(sot, "сто""двести""триста", _  
  34.  "четыреста""пятьсот""шестьсот""семьсот""восемьсот", _  
  35.  "девятьсот") + " "  
  36.  End If  
  37.  If des = 1 Then  
  38.  fSUMprop = fSUMprop + Choose(edi + 1, "десять""одиннадцать", _  
  39.  "двенадцать""тринадцать""четырнадцать""пятнадцать""шестнадцать", _  
  40.  "семнадцать""восемнадцать""девятнадцать") + " "  
  41.  ind = 3  
  42.  Else  
  43.  If des <> 0 Then  
  44.  fSUMprop = fSUMprop + Choose(des - 1, "двадцать", _  
  45.  "тридцать""сорок""пятьдесят""шестьдесят""семьдесят""восемьдесят", _  
  46.  "девяносто") + " "  
  47.  End If  
  48.  If edi <> 0 Then ' вычисляем индекс для тысяч (одна,две)  
  49.  If i = 2 And (edi = 1 Or edi = 2) Then  
  50.  ind = 9  
  51.  Else  
  52.  ind = 0  
  53.  End If  
  54.  fSUMprop = fSUMprop + Choose(edi + ind, "один""два", _  
  55.  "три""четыре""пять""шесть""семь""восемь""девять""одна", _  
  56.  "две") + " "  
  57.  End If  
  58.  Select Case edi  
  59.  Case 1  
  60.  ind = 1  
  61.  Case 2, 3, 4  
  62.  ind = 2  
  63.  Case Else  
  64.  ind = 3  
  65.  End Select  
  66.  End If  
  67.  fSUMprop = fSUMprop + Choose((i - 1) * 3 + ind, "рубль""рубля", _  
  68.  "рублей""тысяча""тысячи""тысяч""миллион""миллиона""миллионов", _  
  69.  "миллиард""миллиарда""миллиардов""триллион""триллиона", _  
  70.  "триллионов") + " "  
  71.  End If  
  72.  Next i  
  73. End If  
  74. ssu = Right$(Format$(xsu, "0.00"), 2)  
  75. des = Val(Left$(ssu, 1))  
  76. edi = Val(Right$(ssu, 1))  
  77. If des = 1 Then  
  78.  ind = 3  
  79. Else  
  80.  Select Case edi  
  81.  Case 1  
  82.  ind = 1  
  83.  Case 2, 3, 4  
  84.  ind = 2  
  85.  Case Else  
  86.  ind = 3  
  87.  End Select  
  88. End If  
  89. fSUMprop = fSUMprop + ssu + Choose(ind, " копейка"" копейки"" копеек")  
  90. If mb = 0 Then  
  91.  fSUMprop = UCase$(Left$(fSUMprop, 1)) + Mid$(fSUMprop, 2)  
  92. End If  
  93. Exit Function  
  94. ersupr:  
  95. fSUMprop = "ошибка"  
  96. End Function  

В прикрепленном файле бухгалтерская форма "Счет" с примером использования функции

Добавил: nilem | | Теги: сумма прописью
Просмотров: 7331 | Рейтинг: 5.0/2
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Рейтинг@Mail.ru Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!