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

Тема в разделе "Оффтоп", создана пользователем Drongo, 5 апр 2013.

  1. Drongo
    Оффлайн

    Drongo Ассоциация VN/VIP Разработчик

    Сообщения:
    7.902
    Симпатии:
    8.221
    Приветы всем.

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

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

    Спасибо
     
  2. regist
    Оффлайн

    regist гоняюсь за туманом Ассоциация VN/VIP VIP Разработчик

    Сообщения:
    11.382
    Симпатии:
    5.268
    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)
     
    Последнее редактирование: 5 апр 2013
    2 пользователям это понравилось.
  3. Drongo
    Оффлайн

    Drongo Ассоциация VN/VIP Разработчик

    Сообщения:
    7.902
    Симпатии:
    8.221
    Да, уже разобрался. Там действительно просто всё. При нажатии на кнопку Установить в книгу добавляется макрос пропись суммы, используется через вызов функции.

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

    Вопрос решён.
     
  4. akok
    Оффлайн

    akok Команда форума Администратор

    Сообщения:
    12.448
    Симпатии:
    13.950
    1 человеку нравится это.
  5. Drongo
    Оффлайн

    Drongo Ассоциация VN/VIP Разработчик

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

Поделиться этой страницей