progr exel

'програма (модуль) запису суми прописом для MS Excel
Option Explicit
Public crit As String
Function Suma_Propisom(dnu As Double) As String
    Dim rub, kop As Long
    Dim dnum As Double
    dnum = dnu + 0.005
    rub = Fix(dnum)
    kop = Fix((dnum - rub) * 100)
    Suma_Propisom = Func_StrNum(dnum, 0) & " руб. " & kop & "коп."
End Function
Function Func_StrNum(dnum As Double, iRod As Integer)
Dim i As Integer
Dim strRes As String
    If dnum < 0 Then
        Func_StrNum = ""
        Exit Function
    End If
    dnum = Fix(dnum)
    If dnum = 0 Then
        Func_StrNum = "Нуль"
        Exit Function
    End If
    strRes = "" 'выходная строка сначала пустая
    i = CInt(Fix(dnum) - Fix((Fix(dnum) / 1000)) * 1000) 'выделяет младшие 3 разряда как целое число 0...999
    If i <> 0 Then
        strRes = Func_0_999(i, iRod)
    End If
    dnum = Fix(dnum / 1000) 'отбрасывает младшие три разряда (обработанные)
    If dnum <> 0 Then
        i = CInt(Fix(dnum) - Fix((Fix(dnum) / 1000)) * 1000) 'выделяет группу из 3 разрядов(тысячи)как целое число 0...999
        If i <> 0 Then
            If strRes <> "" Then
                strRes = " " & strRes
            End If
            strRes = Func_0_999(i, 1) & Func_0_999_Def(i, 2) & strRes
        End If
    Else
        GoTo lbUpFirst
    End If
    dnum = Fix(dnum / 1000)
    If dnum <> 0 Then
        i = CInt(Fix(dnum) - Fix((Fix(dnum) / 1000)) * 1000) 'выделяет группу из 3 разрядов(миллионы) как целое число 0...999
        If i <> 0 Then
            If strRes <> "" Then
                strRes = " " & strRes
            End If
            strRes = Func_0_999(i, 0) & Func_0_999_Def(i, 3) & strRes
        End If
    Else
        GoTo lbUpFirst
    End If
    dnum = Fix(dnum / 1000)
    If dnum <> 0 Then
        i = CInt(Fix(dnum) - Fix((Fix(dnum) / 1000)) * 1000) 'выделяет группу из 3 разрядов(миллиарды)как целое число 0...999
        If i <> 0 Then
            If strRes <> "" Then
                strRes = " " & strRes
            End If
            strRes = Func_0_999(i, 0) & Func_0_999_Def(i, 4) & strRes
        End If
    Else
        GoTo lbUpFirst
    End If
lbUpFirst:
        Func_StrNum = UCase(Left(strRes, 1)) & Right(strRes, Len(strRes) - 1) 'делает первую букву большой
End Function

Function Func_0_999_Def(ByVal inum As Integer, iDef As Integer)
'выбор варианта определяющего слова
    'iDef=0 - копійка
     'iDef=1 - гривня
     'iDef=2 - тисяча
     'iDef=3 - мільйон
     'iDef=4 - мільярд
     'iDef=5 - день
Dim DefVars As Variant
Dim ivar As Integer
DefVars = Array("копійка", "копійки", "копійок", _
               "гривня", "гривні", "гривень", _
               "тисяча", "тисячі", "тисяч", _
               "мільйон", "мільйона", "мільйонів", _
               "мільярд", "мільярда", "мільярдів", _
               "день", "дня", "днів")
inum = inum Mod 100
iDef = iDef Mod 6
Select Case True
    Case inum >= 5 And inum <= 20
        ivar = 2
    Case (inum Mod 10) = 1
        ivar = 0
    Case (inum Mod 10) >= 2 And (inum Mod 10) <= 4
        ivar = 1
    Case Else
        ivar = 2
    End Select
    Func_0_999_Def = " " & DefVars(iDef * 3 + ivar)
End Function

Function Func_0_999(inum As Integer, iRod As Integer)
'Число из диапазона 0...999 прописью, используется в функции Func_0_999_Def
    'iRod=0 - муж род
    'iRod=1 - жен род имен падеж
    'iRod=2 - жен род винит падеж
    'inum - преобразуемое число
Dim WordsNum As Variant
Dim prp As String, i, j As Integer
WordsNum = Array("один", "два", "три", "чотири", "п'ять", "шість", "сім", "вісім", "дев'ять", "десять", _
               "одинадцять", "дванадцять", "тринадцять", "чотирнадцять", "п'ятнадцять", "шістнадцять", "сімнадцять", "вісімнадцять", "дев'ятнадцять", _
               "двадцять", "тридцять", "сорок", "п'ятьдесят", "шістьдесят", "сімдесят", "вісімдесят", "дев'яносто", _
               "сто", "двісті", "триста", "чотириста", "п'ятьсот", "шiстьсот", "сiмсот ", "вiсiмсот", "дев'ятьсот")
    If iRod = 1 Then
        WordsNum(0) = "одна"
        WordsNum(1) = "двi"
    Else
        If iRod = 2 Then
            WordsNum(0) = "одну"
            WordsNum(1) = "двi"
        End If
    End If
    prp = "" 'выходная строка сначала пустая
    i = inum \ 100 'число сотен
    If i <> 0 Then
        prp = WordsNum(i + 26) 'выбор слова сотен, счёт от 0 - поэтому 26
    End If
    i = inum - i * 100 'удаление сотен
    If i <> 0 Then
        If i <= 20 Then
            prp = prp & " " & WordsNum(i - 1)
        Else
            j = i \ 10  'число десятков от 3
            prp = prp & " " & WordsNum(j + 17)
            j = i - j * 10
            If j <> 0 Then
                prp = prp & " " & WordsNum(j - 1)
            End If
        End If
    End If
    If prp <> "" Then
        prp = Left(prp, Len(prp))
    End If
    Func_0_999 = prp
End Function