[MS Excel] Сумма прописью

Drongo

Ассоциация VN/VIP
VIP
Сообщения
7,345
Реакции
4,793
Приветы всем.

Мне на днях нужно было в экселе реализовать сумму прописью, чтобы при сумме скажем: 517.18 печаталось: пятьсот семнадцать руб. 18 коп., или на украинском языке. Пока искал нужные мне варианты написал свою, малец ламерскую, но более-менее рабочую версию суммы прописью. В инете реализаций много, позже я нашёл не плохую реализацию на русском и украинском языке, проблем с подключением и использованием нет. Всё зашибенно.

Но до этого я нашёл такой вариант, думал перепрофилировать под украинский, но к сожалению, я с этой версией прописью суммы так и не разобрался как его юзать, подключить. А интересно. Может кто-нибудь помочь в вопросе? Как использовать вариант по второй ссылке?

Спасибо
 
Drongo, там используются макросы на бейсике
код макросов под спойлерами
PHP:
Attribute VB_Name = "Num"


' ------------------------------------------
' ЧИСЛОПРОПИСЬЮ
'
' Дата создания : 22 апреля 99 г.
' Автор         : Артём Луканин
' Последнее
'   обновление  : 20 апреля 2000 г.
' ------------------------------------------
'
Public Function ЧИСЛОПРОПИСЬЮ(Num) As String
Attribute ЧИСЛОПРОПИСЬЮ.VB_ProcData.VB_Invoke_Func = " \n14"
Dim newNum As Integer, i As Integer, j As Integer
Dim temp As String
  Num = CDbl(Num)
  If Num < 0 Then
    ЧИСЛОПРОПИСЬЮ = "Отрицательное число!!!"
    Exit Function
  End If
  Num = Num * 100
  Num = Int(CDbl(CStr(Num)))
  If Num > 99999999999999# Then
    ЧИСЛОПРОПИСЬЮ = "Слишком большое число!!!"
    Exit Function
  End If
  ЧИСЛОПРОПИСЬЮ = Right(CStr(Num), 2) & " коп."
  If Len(CStr(Num)) = 1 Then ЧИСЛОПРОПИСЬЮ = "0" & ЧИСЛОПРОПИСЬЮ
  ЧИСЛОПРОПИСЬЮ = "руб. " & ЧИСЛОПРОПИСЬЮ
  Num = Int(Num / 100)
  If Num = 0 Then
    ЧИСЛОПРОПИСЬЮ = "Ноль " & ЧИСЛОПРОПИСЬЮ
    Exit Function
  End If
  j = 0
  For i = 1 To Len(CStr(Num))
    newNum = CDbl(Right$(CStr(Num), 1))
    Num = Int(Num / 10)
    If i Mod 3 = 1 Then
      j = j + 1
      If CDbl(Right$(CStr(Num), 1)) = 1 Then
        Select Case newNum
          Case 1
            temp = "одиннадцать "
          Case 2
            temp = "двенадцать "
          Case 3
            temp = "тринадцать "
          Case 4
            temp = "четырнадцать "
          Case 5
            temp = "пятнадцать "
          Case 6
            temp = "шестнадцать "
          Case 7
            temp = "семнадцать "
          Case 8
            temp = "восемнадцать "
          Case 9
            temp = "девятнадцать "
          Case 0
            temp = "десять "
        End Select
        If j = 2 Then
          temp = temp & "тысяч "
        ElseIf j = 3 Then
          temp = temp & "миллионов "
        ElseIf j = 4 Then
          temp = temp & "миллиардов "
        End If
        ЧИСЛОПРОПИСЬЮ = temp & ЧИСЛОПРОПИСЬЮ
        Num = Int(Num / 10)
        i = i + 1
      Else
        Select Case newNum
          Case 1
            If j = 1 Then
              temp = "один "
            ElseIf j = 2 Then
              temp = "одна тысяча "
            ElseIf j = 3 Then
              temp = "один миллион "
            ElseIf j = 4 Then
              temp = "один миллиард "
            End If
          Case 2
            If j = 1 Then
              temp = "два "
            ElseIf j = 2 Then
              temp = "две тысячи "
            ElseIf j = 3 Then
              temp = "два миллиона "
            ElseIf j = 4 Then
              temp = "два миллиарда "
            End If
          Case 3
            If j = 1 Then
              temp = "три "
            ElseIf j = 2 Then
              temp = "три тысячи "
            ElseIf j = 3 Then
              temp = "три миллиона "
            ElseIf j = 4 Then
              temp = "три миллиарда "
            End If
          Case 4
            If j = 1 Then
              temp = "четыре "
            ElseIf j = 2 Then
              temp = "четыре тысячи "
            ElseIf j = 3 Then
              temp = "четыре миллиона "
            ElseIf j = 4 Then
              temp = "четыре миллиарда "
            End If
          Case 5
            temp = "пять "
          Case 6
            temp = "шесть "
          Case 7
            temp = "семь "
          Case 8
            temp = "восемь "
          Case 9
            temp = "девять "
          Case 0
            temp = ""
        End Select
        
        If newNum = 0 Then
          If CDbl(Right$(CStr(Num), 2)) <> 0 Then
            Select Case j
              Case 2
                temp = temp & "тысяч "
              Case 3
                temp = temp & "миллионов "
              Case 4
                temp = temp & "миллиардов "
            End Select
          End If
        ElseIf newNum > 4 Then
          Select Case j
            Case 2
              temp = temp & "тысяч "
            Case 3
              temp = temp & "миллионов "
            Case 4
              temp = temp & "миллиардов "
          End Select
        End If
        ЧИСЛОПРОПИСЬЮ = temp & ЧИСЛОПРОПИСЬЮ
      End If
    ElseIf i Mod 3 = 2 Then
      Select Case newNum
          Case 2
            temp = "двадцать "
          Case 3
            temp = "тридцать "
          Case 4
            temp = "сорок "
          Case 5
            temp = "пятьдесят "
          Case 6
            temp = "шестьдесят "
          Case 7
            temp = "семьдесят "
          Case 8
            temp = "восемьдесят "
          Case 9
            temp = "девяносто "
          Case 0
            temp = ""
        End Select
        ЧИСЛОПРОПИСЬЮ = temp & ЧИСЛОПРОПИСЬЮ
    Else
      Select Case newNum
        Case 1
          temp = "сто "
        Case 2
          temp = "двести "
        Case 3
          temp = "триста "
        Case 4
          temp = "четыреста "
        Case 5
          temp = "пятьсот "
        Case 6
          temp = "шестьсот "
        Case 7
          temp = "семьсот "
        Case 8
          temp = "восемьсот "
        Case 9
          temp = "девятьсот "
        Case 0
          temp = ""
      End Select
      ЧИСЛОПРОПИСЬЮ = temp & ЧИСЛОПРОПИСЬЮ
    End If
  Next i
  Mid(ЧИСЛОПРОПИСЬЮ, 1, 1) = UCase(Mid(ЧИСЛОПРОПИСЬЮ, 1, 1))
End Function

PHP:
Attribute VB_Name = "Installation"

Sub cmdInstall_click()
Attribute cmdInstall_click.VB_ProcData.VB_Invoke_Func = " \n14"
Dim c As String, ab As String, newname As String
Dim i As Integer
  c$ = Application.StartupPath
  If Dir(c$ & "\" & "ARTSOFT_N.XLS") <> "ARTSOFT_N.XLS" Then
    ab$ = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    Sheets("Num").Visible = True
    Sheets("Num").Copy
    With ActiveWorkbook
      .Title = ""
      .Subject = ""
      .Author = "Artyom Lukanin"
      .Keywords = ""
      .Comments = ""
    End With
    newname$ = ActiveWorkbook.Name
    ActiveWindow.Visible = False
    On Error Resume Next
    Workbooks(newname$).SaveAs FileName:=c$ & "\" & _
        "NUMBER.XLS", FileFormat:=xlNormal, Password:="", _
        WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    If Err <> 0 Then
      MsgBox "Не удалось создать книгу с функцией в каталоге" & _
          Chr(13) & c$, vbCritical
      Workbooks(newname$).Close False
      Exit Sub
    End If
    Sheets("Num").Visible = False
    Application.ScreenUpdating = True
    MsgBox "Теперь функция ЧИСЛОПРОПИСЬЮ доступна в разделе" & _
      Chr(13) & """Функции, определённые пользователем""", vbExclamation
  Else
    MsgBox "Функция ЧИСЛОПРОПИСЬЮ уже установлена. Она доступна" & _
      Chr(13) & "в разделе ""Функции, определённые пользователем""", vbInformation
  End If
End Sub


Sub cmdUninstall_Click()
Attribute cmdUninstall_Click.VB_ProcData.VB_Invoke_Func = " \n14"
Dim c As String
  c$ = Application.StartupPath
  If Dir(c$ & "\ARTSOFT_N.XLS") = "ARTSOFT_N.XLS" Then
    Workbooks("ARTSOFT_N.XLS").Close False
    On Error Resume Next
    Kill c$ & "\ARTSOFT_N.XLS"
    If Err = 0 Then
      MsgBox "Функция ЧИСЛОПРОПИСЬЮ успешно была" & Chr(13) & _
          "удалена с Вашего компьютера", vbExclamation
    Else
      MsgBox "Не удалось удалить книгу ARTSOFT_N.XLS в каталоге" & _
          Chr(13) & c$, vbCritical
    End If
  Else
    MsgBox "Функция ЧИСЛОПРОПИСЬЮ не найдена на Вашем компьютере.", vbInformation
  End If
End Sub

Для того чтобы эта функция заработала надо нажать на кнопку Установить, после этого появляется пользовательская функция осуществляющая перевод числа в пропись. К примеру в ячейке А1 у нас число, которое надо вывести прописью в ячейке B2. Тогда в ячейке B2 надо написать функцию =ЧИСЛОПРОПИСЬЮ(A1)
 
Последнее редактирование:
Да, уже разобрался. Там действительно просто всё. При нажатии на кнопку Установить в книгу добавляется макрос пропись суммы, используется через вызов функции.

P.S. Не сработала кнопка первый раз и отсюда непонятки.

Вопрос решён.
 
У меня забраковал офис макрос
Можно по подробнее? Почему забраковал? У меня в офисе 2003 норм, а на стартер 2010 похоже ограничение урезаной версии, не понимает макросы.
 
Назад
Сверху Снизу