Видеоуроки,Выходные формы и макросы,Статьи
Макрос с надстройкой “Сумма прописью в Excel”
Макрос с надстройкой “Сумма прописью в Excel”
Сегодня я покажу как можно быстро сделать сумму прописью в экселе.
Иногда бухгалтерия и финансовый отдел требуют, чтобы была данная строка в актах КС-2.
Изначально в экселе такой функционал отсутствует, но можно сделать макрос обработки данных для решения этой задачи.
В видео я покажу как пользоваться данной бесплатной надстройкой для эксель и как настроить ее для своих нужд.
Надстройка с макросом уже готова и вы можете скачать ее по ссылке. Но я расскажу как создать файл с нуля.
| Рекомендуем! Бесплатный вебинар "4 шага к профессии "Сметчик". Секреты финансового успеха в сметном деле для новичков и опытных. Принять участие >> |
Создание файла надстройки Excel
Создайте новый файл и сохраните его как надстройку с расширением xlam
Функция «Сумма прописью для Excel»
Для того чтобы эксель смог преобразовывать числа в слова, нужно создать новый модуль с функцией. В примере ниже функция называется “ЧислоПрописьюВалюта”.
Код следующий:
Function ЧислоПрописьюВалюта(Число As Double, Optional Валюта As Integer = 1, Optional Копейки As Integer = 1) Dim Edinicy(0 To 19) As String: Dim EdinicyPoslednie(0 To 19) As String Dim Desyatki(0 To 9) As String: Dim Sotni(0 To 9) As String: Dim mlrd(0 To 9) As String Dim mln(0 To 9) As String: Dim tys(0 To 9) As String Dim SumInt, x, shag, vl As Integer: Dim txt, Sclon_Tys As String '--------------------------------------------- Application.Volatile '--------------------------------------------- Edinicy(0) = "": EdinicyPoslednie(0) = IIf(Валюта = 0, "евро", IIf(Валюта = 1, "рублей", "долларов")) Edinicy(1) = "один ": EdinicyPoslednie(1) = IIf(Валюта = 0, "один евро", IIf(Валюта = 1, "один рубль", "один доллар")) Edinicy(2) = "два ": EdinicyPoslednie(2) = IIf(Валюта = 0, "два евро", IIf(Валюта = 1, "два рубля", "два доллара")) Edinicy(3) = "три ": EdinicyPoslednie(3) = IIf(Валюта = 0, "три евро", IIf(Валюта = 1, "три рубля", "три доллара")) Edinicy(4) = "четыре ": EdinicyPoslednie(4) = IIf(Валюта = 0, "четыре евро", IIf(Валюта = 1, "четыре рубля", "четыре доллара")) Edinicy(5) = "пять ": EdinicyPoslednie(5) = IIf(Валюта = 0, "пять евро", IIf(Валюта = 1, "пять рублей", "пять долларов")) Edinicy(6) = "шесть ": EdinicyPoslednie(6) = IIf(Валюта = 0, "шесть евро", IIf(Валюта = 1, "шесть рублей", "шесть долларов")) Edinicy(7) = "семь ": EdinicyPoslednie(7) = IIf(Валюта = 0, "семь евро", IIf(Валюта = 1, "семь рублей", "семь долларов")) Edinicy(8) = "восемь ": EdinicyPoslednie(8) = IIf(Валюта = 0, "восемь евро", IIf(Валюта = 1, "восемь рублей", "восемь долларов")) Edinicy(9) = "девять ": EdinicyPoslednie(9) = IIf(Валюта = 0, "девять евро", IIf(Валюта = 1, "девять рублей", "девять долларов")) Edinicy(11) = "одиннадцать ": EdinicyPoslednie(11) = IIf(Валюта = 0, "одиннадцать евро", IIf(Валюта = 1, "одиннадцать рублей", "одиннадцать долларов")) Edinicy(12) = "двенадцать ": EdinicyPoslednie(12) = IIf(Валюта = 0, "двенадцать евро", IIf(Валюта = 1, "двенадцать рублей", "двенадцать долларов")) Edinicy(13) = "тринадцать ": EdinicyPoslednie(13) = IIf(Валюта = 0, "тринадцать евро", IIf(Валюта = 1, "тринадцать рублей", "тринадцать долларов")) Edinicy(14) = "четырнадцать ": EdinicyPoslednie(14) = IIf(Валюта = 0, "четырнадцать евро", IIf(Валюта = 1, "четырнадцать рублей", "четырнадцать долларов")) Edinicy(15) = "пятнадцать ": EdinicyPoslednie(15) = IIf(Валюта = 0, "пятнадцать евро", IIf(Валюта = 1, "пятнадцать рублей", "пятнадцать долларов")) Edinicy(16) = "шестнадцать ": EdinicyPoslednie(16) = IIf(Валюта = 0, "шестнадцать евро", IIf(Валюта = 1, "шестнадцать рублей", "шестнадцать долларов")) Edinicy(17) = "семнадцать ": EdinicyPoslednie(17) = IIf(Валюта = 0, "семнадцать евро", IIf(Валюта = 1, "семнадцать рублей", "семнадцать долларов")) Edinicy(18) = "восемнадцать ": EdinicyPoslednie(18) = IIf(Валюта = 0, "восемнадцать евро", IIf(Валюта = 1, "восемнадцать рублей", "восемнадцать долларов")) Edinicy(19) = "девятнадцать ": EdinicyPoslednie(19) = IIf(Валюта = 0, "девятнадцать евро", IIf(Валюта = 1, "девятнадцать рублей", "девятнадцать долларов")) ''--------------------------------------------- Desyatki(0) = "": Sotni(0) = "": tys(0) = "тысяч ": mln(0) = "миллионов ": mlrd(0) = "миллиардов " Desyatki(1) = "десять ": Sotni(1) = "сто ": tys(1) = "тысяча ": mln(1) = "миллион ": mlrd(1) = "миллиарда " Desyatki(2) = "двадцать ": Sotni(2) = "двести ": tys(2) = "тысячи ": mln(2) = "миллиона ": mlrd(2) = "миллиарда " Desyatki(3) = "тридцать ": Sotni(3) = "триста ": tys(3) = "тысячи ": mln(3) = "миллиона ": mlrd(3) = "миллиарда " Desyatki(4) = "сорок ": Sotni(4) = "четыреста ": tys(4) = "тысячи ": mln(4) = "миллиона ": mlrd(4) = "миллиарда " Desyatki(5) = "пятьдесят ": Sotni(5) = "пятьсот ": tys(5) = "тысяч ": mln(5) = "миллионов ": mlrd(5) = "миллиардов " Desyatki(6) = "шестьдесят ": Sotni(6) = "шестьсот ": tys(6) = "тысяч ": mln(6) = "миллионов ": mlrd(6) = "миллиардов " Desyatki(7) = "семьдесят ": Sotni(7) = "семьсот ": tys(7) = "тысяч ": mln(7) = "миллионов ": mlrd(7) = "миллиардов " Desyatki(8) = "восемьдесят ": Sotni(8) = "восемьсот ": tys(8) = "тысяч ": mln(8) = "миллионов ": mlrd(8) = "миллиардов " Desyatki(9) = "девяносто ": Sotni(9) = "девятьсот ": tys(9) = "тысяч ": mln(9) = "миллионов ": mlrd(9) = "миллиардов " '--------------------------------------------- On Error Resume Next SumInt = Int(Число) For x = Len(SumInt) To 1 Step -1 shag = shag + 1 Select Case x Case 12 ' - сотни миллиардов vl = Mid(SumInt, shag, 1) txt = txt & Sotni(vl) Case 11 ' - десятки миллиардов vl = Mid(SumInt, shag, 1) If vl = "1" And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo 10 Else txt = txt & Desyatki(vl) ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки Case 10 ' - единицы миллиардов vl = Mid(SumInt, shag, 1) If shag > 1 Then If Mid(SumInt, shag - 1, 1) = 1 Then txt = txt & Edinicy(Mid(SumInt, shag - 1, 2)) & "миллиардов " Else txt = txt & Edinicy(vl) & mlrd(vl) 'числа в диапозоне от 11 до 19 склоняются на "миллиардов" независимо от последнего числа триады Else txt = txt & Edinicy(vl) & mlrd(vl) End If '-КОНЕЦ БЛОКА_______________________ Case 9 ' - сотни миллионов vl = Mid(SumInt, shag, 1) txt = txt & Sotni(vl) Case 8 ' - десятки миллионов vl = Mid(SumInt, shag, 1) If vl = "1" And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo 10 Else txt = txt & Desyatki(vl) ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки Case 7 ' - единицы миллионов vl = Mid(SumInt, shag, 1) If shag > 2 Then If (Mid(SumInt, shag - 2, 1) = 0 And Mid(SumInt, shag - 1, 1) = 0 And vl = "0") Then GoTo 10 End If If shag > 1 Then If Mid(SumInt, shag - 1, 1) = 1 Then txt = txt & Edinicy(Mid(SumInt, shag - 1, 2)) & "миллионов " Else: txt = txt & Edinicy(vl) & mln(vl) 'числа в диапозоне от 11 до 19 склоняются на "миллиардов" независимо от последнего числа триады Else txt = txt & Edinicy(vl) & mln(vl) End If '-КОНЕЦ БЛОКА_______________________ Case 6 ' - сотни тысяч vl = Mid(SumInt, shag, 1) txt = txt & Sotni(vl) Case 5 ' - десятки тысяч vl = Mid(SumInt, shag, 1) If vl = 1 And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo 10 Else txt = txt & Desyatki(vl) ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки Case 4 ' - единицы тысяч vl = Mid(SumInt, shag, 1) If shag > 2 Then If (Mid(SumInt, shag - 2, 1) = 0 And Mid(SumInt, shag - 1, 1) = 0 And vl = "0") Then GoTo 10 End If Sclon_Tys = Edinicy(vl) & tys(vl) ' - вводим переменную Sclon_Tys из-за иного склонения тысяч в русском языке If vl = 1 Then Sclon_Tys = "одна " & tys(vl) ' - для тысяч склонение "один" и "два" неприменимо ( поэтому вводим переменную Sclon_Tys ) If vl = 2 Then Sclon_Tys = "две " & tys(vl) ' - для тысяч склонение "один" и "два" неприменимо ( поэтому вводим переменную Sclon_Tys ) If shag > 1 Then If Mid(SumInt, shag - 1, 1) = 1 Then Sclon_Tys = Edinicy(Mid(SumInt, shag - 1, 2)) & "тысяч " End If txt = txt & Sclon_Tys '-КОНЕЦ БЛОКА_______________________ Case 3 ' - сотни vl = Mid(SumInt, shag, 1) txt = txt & Sotni(vl) Case 2 ' - десятки vl = Mid(SumInt, shag, 1) If vl = "1" And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo 10 Else txt = txt & Desyatki(vl) ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки Case 1 ' - единицы If Mid(SumInt, shag - 1, 1) <> 1 Or Mid(SumInt, shag - 1, 2) = "10" Then vl = Mid(SumInt, shag, 1) Else vl = Mid(SumInt, shag - 1, 2) txt = txt & EdinicyPoslednie(vl) '-КОНЕЦ БЛОКА_______________________ End Select 10: Next x a = Число b = Int(a) c = (Round(a - b, 2)) * 100 If c < 10 And c >= 1 Then c = "0" + CStr(c) If c = 0 Then c = CStr(c) + "0" d = "" If Валюта = 1 Then d = " коп." Else d = " цен." If Валюта > 2 Or Валюта < 0 Then MsgBox "Укажите параметр 0-2" If Валюта > 2 Or Валюта < 0 Then GoTo 11 If Копейки = 0 Then d = "" c = "" End If If Копейки = 2 Then d = "" If Копейки > 2 Or Копейи < 0 Then MsgBox "Укажите параметр 0, 1 или 2" If Копейки > 2 Or Копейки < 0 Then GoTo 11 ЧислоПрописьюВалюта = UCase(Left(txt, 1)) & LCase(Mid(txt, 2)) + " " + CStr(c) + d 11: End Function Sub DescribeFunction() Dim FuncName As String Dim FuncDesc As String Dim Category As String Dim ArgDesc(1 To 3) As String FuncName = "ЧислоПрописьюВалюта" FuncDesc = "Функция преобразовывает число суммы текстовыми словами" Category = 1 'Text category ArgDesc(1) = "Исходная сумма" ArgDesc(2) = "(необязательный) Тип отображаемой валюты 0-Евро, 1-Рубли, 2-Доллары." ArgDesc(3) = "(необязательный) Нужны ли копейки: 0-нет, 1-отображать копейки стандартно, 2-отображать только дробную часть (без слов)." Application.MacroOptions _ Macro:=FuncName, _ Description:=FuncDesc, _ Category:=Category, _ ArgumentDescriptions:=ArgDesc End Sub
Этот код я разместил в отдельном модуле.
Вы можете использовать эту функциию также путем вызова в ячейке эксель формулы:
“=ЧислоПрописьюВалюта(“Номер ячейки”)”
При таком способе вызова функции важно, чтобы в ячейке был настроем формат “Общий”, иначе она не сработает.
Создание макроса для быстрого запуска под вашу задачу
Чтобы каждый раз не вводить формулу функции, можно автоматизировать данную задачу, создав макрос.
Для этого в файле надстройки создайте отдельный модуль с кодом:
Sub macros1()
' ищем вcего по акту
Set oCell = Cells.Find(What:="ВСЕГО по акту", After:=Cells(1, 1), LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
If oCell Is Nothing Then
MsgBox "Не найдена строка ВСЕГО по акту!"
Exit Sub
Else
a = oCell.Row
With Cells(a + 1, 1)
.Value = "Всего: " & ЧислоПрописьюВалюта(Cells(a, "o"))
.VerticalAlignment = xlTop
End With
End If
End Sub
Этот макрос будет искать строку “ВСЕГО по акту” и ниже нее на 1 строку вставлять в первый столбец функцию суммы прописи (ЧислоПрописьюВалюта), которую мы создали выше. Данные будут взяты из ячейки со столбцом “А” и той строкой где макрос найдет фразу “ВСЕГО по акту”.
Создание отдельной панели для запуска макроса
Теперь нужно сделать, чтобы макрос запускался быстро и удобно прямо с панели.
Для этого нужно создать еще один модуль в визуальном редакторе кода.
Вот код для вставки в модуль:
'---------------------------------------------------------------------------------------
' Модуль : CreateMenu
' Автор : EducatedFool (Игорь) Дата: 08.03.2010
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://excelvba.ru/ ICQ: 5836318 Skype: ExcelVBA.ru
' Номер счёта WebMoney для оплаты: R318574877619
'---------------------------------------------------------------------------------------
' ВНИМАНИЕ! Наличие константы PROJECT_NAME ОБЯЗАТЕЛЬНО!
Public Const PROJECT_NAME = "Addin CommandBar"
' список допустимых элементов управления на пользовательской панели инструментов
Public Enum CONTROL_TYPES
ct_BUTTON = msoControlButton
ct_TEXTBOX = msoControlEdit
ct_COMBOBOX = msoControlComboBox
ct_DROPDOWN = msoControlDropdown
ct_POPUP = msoControlPopup
End Enum
Function Add_Control(ByRef Comm_Bar, ByVal ControlType As CONTROL_TYPES, ByVal B_Face As Integer, _
ByVal On_Action As String, ByVal B_Caption As String, _
Optional ByVal Button_Style As MsoButtonStyle = msoButtonIcon, _
Optional ByVal Begin_Group As Boolean = False, _
Optional Tag As String = "") As CommandBarControl
' добавляет контролы в меню Comm_Bar, возвращает ссылку на созданный пункт меню
On Error Resume Next
Set Add_Control = Comm_Bar.Controls.Add(Type:=ControlType, Temporary:=True) ' создаём новый контрол
With Add_Control
If B_Face > 0 And ControlType = ct_BUTTON Then .FaceId = B_Face ' назначаем кнопке иконку
.Tag = Tag: .OnAction = On_Action: .Caption = B_Caption ' параметры контрола
.BeginGroup = Begin_Group ' добавляем разделитель (при необходимости)
If ControlType = ct_BUTTON Then .Style = Button_Style
End With
End Function
Function GetCommandBar(ByVal CommandBarName As String, Optional ByVal Clean As Boolean = False, _
Optional ByVal Position As MsoBarPosition = msoBarFloating) As CommandBar
On Error Resume Next: Err.Clear
' получаем ссылку на пользовательскую панель инструментов
Set GetCommandBar = Application.CommandBars(CommandBarName)
If Err.Number Then ' если панель не найдена - создаём её
Set GetCommandBar = Application.CommandBars.Add(CommandBarName, Position, False, True)
End If
If Clean Then ' перебираем на ней все элементы, и удаляем их
For Each cbc In GetCommandBar.Controls: cbc.Delete: Next
End If
GetCommandBar.Visible = True ' отображаем панель инструментов
End Function
Sub УдалениеПанелиИнструментов()
GetCommandBar PROJECT_NAME, True
End Sub
Sub ФормированиеПанелиИнструментов()
On Error Resume Next: Application.ScreenUpdating = False
' получаем ссылку на пользовательскую панель инструментов
Set AddinMenu = GetCommandBar(PROJECT_NAME, True)
' добавление новых элементов управления на панель
Add_Control AddinMenu, ct_BUTTON, 1099, "macros1", "Запуск основного макроса", msoButtonIconAndCaption, True
End Sub
Sub SetIsAddinAsFalse()
On Error Resume Next: ThisWorkbook.IsAddin = False
End Sub
Sub SetIsAddinAsTrue()
On Error Resume Next: ThisWorkbook.IsAddin = True
End Sub
Sub CreateBackup()
' сохраняет файл надстройки, и создаёт резервную копию файла в специальной папке
On Error Resume Next
If Not ThisWorkbook.Saved Then ThisWorkbook.Save ' сохранение файла
' формируем путь к папке для резервных копий программы
BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
' создаём папку, если она не существует
MkDir BackupsPath
' формируем путь для файла резервной копии
Filename = PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".xls"
' создаём копию файла надстройки
ThisWorkbook.SaveCopyAs BackupsPath & Filename
End Sub
Sub ComboChanged() ' срабатывает при изменении значения в комбобоксе или текстбоксе
On Error Resume Next
НазваниеКомбобокса = Application.CommandBars.ActionControl.Tag
ТекстКомбобокса = Application.CommandBars.ActionControl.Text
MsgBox "Новое значение: """ & ТекстКомбобокса & """", _
vbInformation, "Изменения в поле\списке """ & НазваниеКомбобокса & """"
End Sub
Sub AdditionalMacros() ' срабатывает при нажатии одной из кнопок в подменю
On Error Resume Next
НомерМакроса = Application.CommandBars.ActionControl.Tag
MsgBox "Параметр макроса = """ & НомерМакроса & """", vbInformation, "Запущен макрос из подменю"
End Sub
Возможно, этот код излишне сложный, если вы разбираетесь в VBA, вы можете уменьшить его объем. Но он работает вполне исправно.
Еще нужно добавить код в книгу созданного файла надстройки, иначе при ее запуске у вас не появится дополнительная панель “Надстройки” с кнопкой для запуска макроса.
Для этого в раздел “ЭтаКнига”в редакторе кода вставляем код:
Private Sub Workbook_BeforeClose(Cancel As Boolean) End Sub Private Sub Workbook_Open() ФормированиеПанелиИнструментов End Sub
Скриншот:
Запуск надстройки с макросом “Сумма прописью” в экселе
Наш файл надстройки готов. Не забудьте сохранить его. По умолчанию эксель сохраняет файл с таким расширением в папку по адресу “C:\Users\ИМЯ ЮЗЕРА\AppData\Roaming\Microsoft\AddIns”
После сохранения вы можете вынести ярлык файла для быстрого запуска на рабочий стол.
Как запустить макрос:
| Рекомендуем! Бесплатный вебинар "4 шага к профессии "Сметчик". Секреты финансового успеха в сметном деле для новичков и опытных. Принять участие >> |
- Откройте любой файл эксель
- Запустите файл надстройки (в нашем примере “ЧислоПрописьюКС2.xlam”)
- Перейдите на появившуюся вкладку “Надстройки” и нажите кнопку “запуск основного макроса”
На этом настрока завершена.
Большую часть кода я взял на просторах интернета. Макрос суммы прописью я разработал сам.
Если вы хорошо разбираетесь в VBA, вы можете скорректировать этот функционал под свои нужды.
Видеоурок по работе и настройке макроса
Описание урока
- 0:22 надстройка для суммы прописью в экселе (excel)
- 1:27 запуск надстройки с макросом
- 3:00 вкладка “разработчик” и настройки для макросов в экселе
- 3:41 настройка макроса “сумма прописью” под себя
- 7:49 сохранение изменений в коде макроса
- 8:22 тест изменений макроса VBA и устранение ошибок
- 11:00 стоковая работа макроса суммы прописью в акты выполненных работ КС2 при выводе из Гранд сметы
Скачать надстройку с макросом суммы прописью в экселе
Заключение
Я всегда пытаюсь максимально автоматизировать свою работу в сметном деле и для этой цели разрабатываю шаблоны смет, выходные формы и макросы обработки данных для сметчиков. Данные продукты помогают допускать меньше ошибок в работе сметчика и сильно сокращают время на производство сметной документации.
В моем интернет-магазине на блоге есть целый раздел, посвященный выходным формам и макросам для облегчения жизни сметчиков. Данные разработки позволяют мне работать меньше, а зарабатывать больше. Если вы так же хотите оптимизировать свою работу, то советую вам присмотреться к моим разработкам в области выходных форм с макросами.
Кроме того, у меня есть много шаблонов и примеров смет, которые предназначены для быстрого составления смет на различные виды работ ресурсным способом (по ГЭСН в ФСНБ 2022). Работа по готовым шаблонам в разы ускоряет изготовление сметной документации, в большинстве случаем исключает проведение конъюнктурного анализа и позволяет даже новичку без опыта и глубоких познаний в сметном деле составлять грамотные сметы.
Так же я советую пройти свой курс по сметному делу, в котором я собрал все важнейшие рекомендации для настоящих и будущих сметчиков о нашей сметной профессии и бесплатный вебинар "4 шага к профессии "Сметчик", на котором я поделюсь свои опытом многолетней работы в сметном деле. Расскажу о том что нужно для старта в профессию "сметчик", расскажу о своих сметных доходах и расходах, опыте участия в сметных госзакупках и многом другом.
Зачем давать скачивать таблицу, если ей нельзя воспользоваться.
а можно поподробнее с этого момента?
После скачивания таблица не работает. Ни одна вкладка не активна. Таблица защищена.
там и не должно быть вкладок, это наДстройка эксель… Вы видео смотрели вообще?
Добрый день! подскажите пожалуйста, как прописать в коде первого модуля, склонение «копеек» (чтобы не сокращенно коп.)
Здравствуйте! Во втором модуле строку “If Валюта = 1 Then d = ” коп.” Else d = ” цен.”” заменить на “If Валюта = 1 Then d = ” копеек” Else d = ” цен.”” (https://disk.yandex.ru/i/wzT1SI-muLKgeg) но тогда склонение в падежах появится …
Понятно, спасибо! но нужно еще чтобы работало склонение: например – 1 копейка, 2 копейки, 10 копеек …