Макрос с надстройкой “Сумма прописью в Excel”

Обновлено 05.02.2025

Макрос с надстройкой “Сумма прописью в Excel”

Сегодня я покажу как можно быстро сделать сумму прописью в экселе.

Иногда бухгалтерия и финансовый отдел требуют, чтобы была данная строка в актах КС-2.

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

В видео я покажу как пользоваться данной бесплатной надстройкой для эксель и как настроить ее для своих нужд.

Надстройка с макросом уже готова и вы можете скачать ее по ссылке. Но я расскажу как создать файл с нуля.

Создание файла надстройки 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

Этот код я разместил в отдельном модуле.

Вы можете использовать эту функциию также путем вызова в ячейке эксель формулы:

“=ЧислоПрописьюВалюта(“Номер ячейки”)”

При таком способе вызова функции важно, чтобы в ячейке был настроем формат “Общий”, иначе она не сработает.

Сохранить файл с поддержкой макросов XLSM

Важно!

Если вы не хотите пользоваться надстройкой, а просто решили вставить функцию суммы прописи в какой-то из ваших файлов эксель, то после вставки функции нужно сохранить файл в формате “XLSM”, т.е. с поддержкой макросов.

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

Нажмите “Файл” — “Сохранить как” — “Этот компьютер” — “Выберите путь сохранения и имя” — “Тип файла с поддержкой макросов .XLSM”:

Создание макроса для быстрого запуска под вашу задачу

Чтобы каждый раз не вводить формулу функции, можно автоматизировать данную задачу, создав макрос.

Для этого в файле надстройки создайте отдельный модуль с кодом:

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”

После сохранения вы можете вынести ярлык файла для быстрого запуска на рабочий стол.

Как запустить макрос:

1. Откройте любой файл эксель
2. Запустите файл надстройки (в нашем примере “ЧислоПрописьюКС2.xlam”)
3. Перейдите на появившуюся вкладку “Надстройки” и нажите кнопку “запуск основного макроса”

На этом настройка завершена.

Большую часть кода я взял на просторах интернета. Макрос суммы прописью я разработал сам.

Если вы хорошо разбираетесь в VBA, вы можете скорректировать этот функционал под свои нужды.

Видеоурок по работе и настройке макроса

Описание урока

• 0:22 надстройка для суммы прописью в экселе (excel)
• 1:27 запуск надстройки с макросом
• 3:00 вкладка “разработчик” и настройки для макросов в экселе
• 3:41 настройка макроса “сумма прописью” под себя
• 7:49 сохранение изменений в коде макроса
• 8:22 тест изменений макроса VBA и устранение ошибок
• 11:00 стоковая работа макроса суммы прописью в акты выполненных работ КС2 при выводе из Гранд сметы

Скачать надстройку с макросом суммы прописью в экселе

Заключение

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

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

Кроме того, у меня есть много шаблонов и примеров смет, которые предназначены для быстрого составления смет на различные виды работ ресурсным способом (по ГЭСН в ФСНБ 2022). Работа по готовым шаблонам в разы ускоряет изготовление сметной документации, в большинстве случаем исключает проведение конъюнктурного анализа и позволяет даже новичку без опыта и глубоких познаний в сметном деле составлять грамотные сметы.

Так же я советую пройти свой курс по сметному делу, в котором я собрал все важнейшие рекомендации для настоящих и будущих сметчиков о нашей сметной профессии и бесплатный вебинар "4 шага к профессии "Сметчик", на котором я поделюсь свои опытом многолетней работы в сметном деле. Расскажу о том что нужно для старта в профессию "сметчик", расскажу о своих сметных доходах и расходах, опыте участия в сметных госзакупках и многом другом.