Конвертиране на число в словом с думи за VBA за Microsoft Excel. По подразбиране работи за левове в мъжки род, но може да се използва и за мярка в женски род (например метро единици) или среден род (например евро)

NumberToWords (Bulgarian)

'=====================================================================================================================
'
'   Конвертиране на число в словом с думи за VBA за Microsoft Excel
'   Copyright (c) 2012-2018 Unicontsoft (wqweto@gmail.com)
'
' ОПИСАНИЕ
'
'   По подразбиране конвертира левове (в мъжки род), но може да се използва и за мярка в женски род (например метро
'   единици) или среден род (например евро).
'
' ИНСТАЛАЦИЯ
'
'   Отворете https://gist.github.com/4118581 и натиснете бутон [Raw], за да видите само нужния код. Изберете
'   цялото съдържание с Ctrl+A и копирайте в системния буфер с Ctrl+C
'
'   Стартирайте VBA в Excel с Alt+F11, щракнете с десен бутон на мишката върху VBAProject и изберете
'   Insert->Module от менюто. Поставете копираното съдържание с Ctrl+V в Module1 и затворете редактора.
'
' ИЗПОЛЗВАНЕ
'
'   В клетката, в която желаете да пише сумата словом можете да използвате това:
'
'     = ToWords(123)
'
'   или да подадете стойност на друга клетка (обща стойност на документа) така
'
'     = ToWords(A1)
'
'   което ще превърне числото от A1 в словом в текущата клетка.
'
'   Максимална стойност на първи параметър dblValue e 999 квадрилиона.
'
'     = ToWords(167.42)                   ->   Сто шестдесет и седем лв. и 42 ст.
'     = ToWords(-12341235)                ->   Минус дванадесет милиона триста четиридесет и една хиляди двеста
'                                              тридесет и пет лв.
'     = ToWords(341.6, "МЕ|стотни", "FF") ->   Триста четиридесет и една МЕ и 60 стотни
'     = ToWords(1.03)                     ->   Един лев и 03 ст.
'
' PUBLIC DOMAIN NOTICE AND DISCLAIMER
'
'   The author has placed this work in the Public Domain, thereby relinquishing all copyrights. Everyone is free to
'   use, modify, republish, sell or give away this work without prior consent from anybody.
'
'   This work is provided on an “as is” basis, without warranty of any kind. Use at your own risk! Under no
'   circumstances shall the author(s) or contributor(s) be liable for damages resulting directly or indirectly from
'   the use or non-use of this work.
'
'=====================================================================================================================

Public Function ToWords(ByVal dblValue As Double, Optional Measure As Variant, Optional Gender As Variant, Optional NumScale As Variant) As String
    Dim vDigits         As Variant
    Dim vGenderDigits   As Variant
    Dim vValue          As Variant
    Dim lIdx            As Long
    Dim lDigit          As Long
    Dim sResult         As String
    
    '--- fix optional params default values
    If IsMissing(Gender) Then
        Gender = vbNullString
    End If
    If IsMissing(NumScale) Then
        NumScale = 2
    End If
    '--- init digits (incl. gender ones)
    vDigits = Split("нула едно две три четири пет шест седем осем девет")
    vGenderDigits = Split(Join(vDigits))
    Select Case Left$(Gender, 1)
    Case vbNullString, "M", ""
        vGenderDigits(1) = "един"
        vGenderDigits(2) = "два"
    Case "F"
        vGenderDigits(1) = "една"
    End Select
    '--- split input value on decimal point and pad w/ zeroes
    vValue = Mid$(Format$(0, "0.0"), 2, 1)
    vValue = Split(Format$(Abs(dblValue), "0." & String(NumScale, "0")), vValue)
    vValue(0) = Right$(String$(18, "0") & vValue(0), 18)
    '--- loop input digits from right to left
    For lIdx = 1 To Len(vValue(0))
        If lIdx <= 3 Then
            lDigit = Mid$(vValue(0), Len(vValue(0)) - lIdx + 1, 1)
        Else
            lDigit = Mid$(vValue(0), Len(vValue(0)) - lIdx - 1, 3)
            lIdx = lIdx + 2
        End If
        If lDigit <> 0 Then
            '--- separate by space (first time prepend "и" too)
            If LenB(sResult) <> 0 And (lIdx <> 2 Or lDigit <> 1) Then
                If InStr(sResult, " и ") = 0 Then
                    sResult = " и " & sResult
                Else
                    sResult = " " & sResult
                End If
            End If
            Select Case lIdx
            Case 1
                sResult = vGenderDigits(lDigit) & sResult
            Case 2
                If lDigit = 1 Then
                    '--- 11 to 19 special wordforms
                    If LenB(sResult) <> 0 Then
                        sResult = Replace(LTrim$(sResult), vGenderDigits(1), "еди")
                        sResult = Replace(sResult, vGenderDigits(2), "два") & "надесет"
                    Else
                        sResult = "десет"
                    End If
                Else
                    sResult = IIf(lDigit = 2, "два", vDigits(lDigit)) & "десет" & sResult
                End If
            Case 3
                '--- hundreds have special suffixes for 2 and 3
                Select Case lDigit
                Case 1
                    sResult = "сто" & sResult
                Case 2, 3
                    sResult = vDigits(lDigit) & "ста" & sResult
                Case Else
                    sResult = vDigits(lDigit) & "стотин" & sResult
                End Select
            Case 6
                '--- thousands are in feminine gender
                Select Case lDigit
                Case 1
                    sResult = "хиляда" & sResult
                Case Else
                    sResult = ToWords(lDigit, vbNullString, Gender:="F") & " хиляди" & sResult
                End Select
            Case 9, 12, 15
                '--- no special cases for bigger values
                sResult = ToWords(lDigit, vbNullString) & " " & Split("милион милиард трилион квадрилион")((lIdx - 9) \ 3) _
                    & IIf(lDigit <> 1, "а", vbNullString) & sResult
            End Select
        End If
    Next
    '--- handle zero and negative values
    If LenB(sResult) = 0 Then
        sResult = vDigits(0)
    End If
    If dblValue < 0 Then
        sResult = "минус " & sResult
    End If
    '--- apply measure (use Measure:=vbNullString for none)
    If IsMissing(Measure) Then
        Measure = IIf(Val(vValue(0)) = 1, "лев", "лв.") & "|ст."
        Gender = "MF"
    End If
    If LenB(Measure) <> 0 Then
        If Right$(sResult, Len(vDigits(0))) = vDigits(0) And Val(vValue(1)) <> 0 And InStr(Measure, "|") > 0 Then
            sResult = ToWords(IIf(dblValue < 0, -1, 1) * Val(vValue(1)), Split(Measure, "|")(1), Mid$(Gender, 2))
        Else
            sResult = sResult & " " & Split(Measure, "|")(0)
            If Val(vValue(1)) <> 0 Or InStr(Measure, "|") > 0 Then
                sResult = sResult & " и " & vValue(1)
            End If
            If InStr(Measure, "|") > 0 Then
                sResult = sResult & " " & Split(Measure, "|")(1)
            End If
            sResult = UCase$(Left$(sResult, 1)) & Mid$(sResult, 2)
        End If
    End If
    ToWords = sResult
End Function

Public Function ToAllWords(ByVal dblValue As Double) As String
    ToAllWords = ToWords(Int(dblValue), "лв.") & " и " & LCase$(ToWords(Round((dblValue - Int(dblValue)) * 100), "ст.", "F"))
End Function

@hristo-atanasov: Да, това е оставено нарочно за да може да се ползва с хилядни, но явно този use-case не е добре тестван.

Добавил съм опционален параметър NumScale който ще предпазва от грешни (не добре закръглени) входни данни. По този начин добре се решава случаят, в който искаме за мярка да подадем "МЕ|хилядни" -- просто подаваме NumScale:=3 за да форматира 2.5 като Две МЕ и 500 хилядни а не 50 хилядни както досега.

За левове и ст. функцията продължава да се ползва както до момента, подава се единствено стойността като първи параметър и екстрата вече е че автоматично закръглява до втория знак. Трябва да се има предвид, че Excel ползва "банкерско" закръгляване, не аритметично на каквото сме свикнали от училище.

cheers,
</wqw>

Здравейте и благодаря за кода!
Имам един малък проблем, работя с LibreOffice и при стартиране на макроса ми дава грешка ...NumScale As Long = 2)..., че вместо "=" очаква " ) ". Макроса работи като изтрия " = 2 ", обаче при извеждане на стотинките ми ги дава във екпоненциялен формат, напр. 56 ст. -> 5,6Е+97 ст. Проблем на Libre ли е или...?
Предварително благодаря!

@andyon123 Проблемът не е в LibreOffice per se. Просто този код не е писан за неговия макро език, така че трябва някой да го преработи за да тръгне.

Edit: Последната ревизия е тествана с OpenOffice и би трябвало да работи и под LibreOffice също. Ако има проблеми пишете тук.

Може ли да се изписва "един лев и 00 ст.", а не както е сега "един лев" . И това да е като опция в "кода"
или къде трябва да се промени в "кода" ако желая да се изписва по този начин.

Пробвайте последната версия, пипнал съм функцията винаги да слага 00 ст.

cheers,
</wqw>

Здравейте, има ли как и цифрите след десетичната запетая да се изписват словом

Здравейте,

Добавил съм втора едноредова функция ToAllWords която работи винаги за левове/стотинки и последните са словом също.

За да я ползвате трябва повторно да си инсталирате модула, както е описано в инструкцията.

Ако не Ви устройва мерките да са лв. и съответно ст. можете да пробвате сами да си ги смените в ToAllWords.

</wqw>

Може ли да го направиш да конвертира на английски.

@zarkomm: Не, в интернет е пълно с английски версии. Пробвай да потърсиш в google.

cheers,
</wqw>

Здравей, отдавна си мислих по проблема и добре, че жена ми ме светна за да се разровя в нета ;-))) Пробвах кода ти и работи чудесно за което искам и да ти благодаря! Само един въпрос. Защото гледам, че е имало допълнения и редакции на бъгове, този като последен вариант ли е? Страхотна работа и благодаря отново!

@BBPopov: Да, текущия код винаги е последната ревизия.

Най-горе има таб Revisions с 22 до него -- там са предишните версии ако нещо те интересува.

cheers,
</wqw>

Благодаря! From: Vladimir Vissoultchev [mailto:notifications@github.com] Sent: Friday, May 31, 2019 11:19 PM To: wqweto Cc: BBPopov; Mention Subject: Re: wqweto/NumberToWords (Bulgarian) @BBPopov <https://github.com/BBPopov> : Да, текущия код винаги е последната ревизия. Най-горе има таб Revisions с 22 до него -- там са предишните версии ако нещо те интересува. cheers, </wqw> — You are receiving this because you were mentioned. Reply to this email directly, view it on GitHub <https://gist.github.com/4118581?email_source=notifications&email_token=AMG6O2WBXKK2KSO5B5KKXALPYGB3PA5CNFSM4HR4QV62YY3PNVWWK3TUL52HS4DFVNDWS43UINXW23LFNZ2KUY3PNVWWK3TUL5UWJTQAFS6PG#gistcomment-2931955> , or mute the thread <https://github.com/notifications/unsubscribe-auth/AMG6O2T6CHPN7C6GPJCEAQTPYGB3PANCNFSM4HR4QV6Q> . <https://github.com/notifications/beacon/AMG6O2RJ6NIBQYG7QVRE3JTPYGB3PA5CNFSM4HR4QV62YY3PNVWWK3TUL52HS4DFVNDWS43UINXW23LFNZ2KUY3PNVWWK3TUL5UWJTQAFS6PG.gif>

Вариант на функцията с unicode кодирана кирилица за тези на които им излизат въпросителни:

Public Function ToWords(ByVal dblValue As Double, Optional Measure As Variant, Optional Gender As Variant, Optional NumScale As Variant) As String
    Dim vDigits         As Variant
    Dim vGenderDigits   As Variant
    Dim vValue          As Variant
    Dim lIdx            As Long
    Dim lDigit          As Long
    Dim sResult         As String
    
    '--- fix optional params default values
    If IsMissing(Gender) Then
        Gender = vbNullString
    End If
    If IsMissing(NumScale) Then
        NumScale = 2
    End If
    '--- init digits (incl. gender ones)
    vDigits = Split(ChrW(&H43D)&ChrW(&H443)&ChrW(&H43B)&ChrW(&H430)&ChrW(&H20)&ChrW(&H435)&ChrW(&H434)&ChrW(&H43D)&ChrW(&H43E)&ChrW(&H20)&ChrW(&H434)&ChrW(&H432)&ChrW(&H435)&ChrW(&H20)&ChrW(&H442)&ChrW(&H440)&ChrW(&H438)&ChrW(&H20)&ChrW(&H447)&ChrW(&H435)&ChrW(&H442)&ChrW(&H438)&ChrW(&H440)&ChrW(&H438)&ChrW(&H20)&ChrW(&H43F)&ChrW(&H435)&ChrW(&H442)&ChrW(&H20)&ChrW(&H448)&ChrW(&H435)&ChrW(&H441)&ChrW(&H442)&ChrW(&H20)&ChrW(&H441)&ChrW(&H435)&ChrW(&H434)&ChrW(&H435)&ChrW(&H43C)&ChrW(&H20)&ChrW(&H43E)&ChrW(&H441)&ChrW(&H435)&ChrW(&H43C)&ChrW(&H20)&ChrW(&H434)&ChrW(&H435)&ChrW(&H432)&ChrW(&H435)&ChrW(&H442))
    vGenderDigits = Split(Join(vDigits))
    Select Case Left$(Gender, 1)
    Case vbNullString, ChrW(&H4D), ""
        vGenderDigits(1) = ChrW(&H435)&ChrW(&H434)&ChrW(&H438)&ChrW(&H43D)
        vGenderDigits(2) = ChrW(&H434)&ChrW(&H432)&ChrW(&H430)
    Case ChrW(&H46)
        vGenderDigits(1) = ChrW(&H435)&ChrW(&H434)&ChrW(&H43D)&ChrW(&H430)
    End Select
    '--- split input value on decimal point and pad w/ zeroes
    vValue = Mid$(Format$(0, ChrW(&H30)&ChrW(&H2E)&ChrW(&H30)), 2, 1)
    vValue = Split(Format$(Abs(dblValue), ChrW(&H30)&ChrW(&H2E) & String(NumScale, ChrW(&H30))), vValue)
    vValue(0) = Right$(String$(18, ChrW(&H30)) & vValue(0), 18)
    '--- loop input digits from right to left
    For lIdx = 1 To Len(vValue(0))
        If lIdx <= 3 Then
            lDigit = Mid$(vValue(0), Len(vValue(0)) - lIdx + 1, 1)
        Else
            lDigit = Mid$(vValue(0), Len(vValue(0)) - lIdx - 1, 3)
            lIdx = lIdx + 2
        End If
        If lDigit <> 0 Then
            '--- separate by space (first time prepend ChrW(&H438) too)
            If LenB(sResult) <> 0 And (lIdx <> 2 Or lDigit <> 1) Then
                If InStr(sResult, ChrW(&H20)&ChrW(&H438)&ChrW(&H20)) = 0 Then
                    sResult = ChrW(&H20)&ChrW(&H438)&ChrW(&H20) & sResult
                Else
                    sResult = ChrW(&H20) & sResult
                End If
            End If
            Select Case lIdx
            Case 1
                sResult = vGenderDigits(lDigit) & sResult
            Case 2
                If lDigit = 1 Then
                    '--- 11 to 19 special wordforms
                    If LenB(sResult) <> 0 Then
                        sResult = Replace(LTrim$(sResult), vGenderDigits(1), ChrW(&H435)&ChrW(&H434)&ChrW(&H438))
                        sResult = Replace(sResult, vGenderDigits(2), ChrW(&H434)&ChrW(&H432)&ChrW(&H430)) & ChrW(&H43D)&ChrW(&H430)&ChrW(&H434)&ChrW(&H435)&ChrW(&H441)&ChrW(&H435)&ChrW(&H442)
                    Else
                        sResult = ChrW(&H434)&ChrW(&H435)&ChrW(&H441)&ChrW(&H435)&ChrW(&H442)
                    End If
                Else
                    sResult = IIf(lDigit = 2, ChrW(&H434)&ChrW(&H432)&ChrW(&H430), vDigits(lDigit)) & ChrW(&H434)&ChrW(&H435)&ChrW(&H441)&ChrW(&H435)&ChrW(&H442) & sResult
                End If
            Case 3
                '--- hundreds have special suffixes for 2 and 3
                Select Case lDigit
                Case 1
                    sResult = ChrW(&H441)&ChrW(&H442)&ChrW(&H43E) & sResult
                Case 2, 3
                    sResult = vDigits(lDigit) & ChrW(&H441)&ChrW(&H442)&ChrW(&H430) & sResult
                Case Else
                    sResult = vDigits(lDigit) & ChrW(&H441)&ChrW(&H442)&ChrW(&H43E)&ChrW(&H442)&ChrW(&H438)&ChrW(&H43D) & sResult
                End Select
            Case 6
                '--- thousands are in feminine gender
                Select Case lDigit
                Case 1
                    sResult = ChrW(&H445)&ChrW(&H438)&ChrW(&H43B)&ChrW(&H44F)&ChrW(&H434)&ChrW(&H430) & sResult
                Case Else
                    sResult = ToWords(lDigit, vbNullString, Gender:=ChrW(&H46)) & ChrW(&H20)&ChrW(&H445)&ChrW(&H438)&ChrW(&H43B)&ChrW(&H44F)&ChrW(&H434)&ChrW(&H438) & sResult
                End Select
            Case 9, 12, 15
                '--- no special cases for bigger values
                sResult = ToWords(lDigit, vbNullString) & ChrW(&H20) & Split(ChrW(&H43C)&ChrW(&H438)&ChrW(&H43B)&ChrW(&H438)&ChrW(&H43E)&ChrW(&H43D)&ChrW(&H20)&ChrW(&H43C)&ChrW(&H438)&ChrW(&H43B)&ChrW(&H438)&ChrW(&H430)&ChrW(&H440)&ChrW(&H434)&ChrW(&H20)&ChrW(&H442)&ChrW(&H440)&ChrW(&H438)&ChrW(&H43B)&ChrW(&H438)&ChrW(&H43E)&ChrW(&H43D)&ChrW(&H20)&ChrW(&H43A)&ChrW(&H432)&ChrW(&H430)&ChrW(&H434)&ChrW(&H440)&ChrW(&H438)&ChrW(&H43B)&ChrW(&H438)&ChrW(&H43E)&ChrW(&H43D))((lIdx - 9) \ 3) _
                    & IIf(lDigit <> 1, ChrW(&H430), vbNullString) & sResult
            End Select
        End If
    Next
    '--- handle zero and negative values
    If LenB(sResult) = 0 Then
        sResult = vDigits(0)
    End If
    If dblValue < 0 Then
        sResult = ChrW(&H43C)&ChrW(&H438)&ChrW(&H43D)&ChrW(&H443)&ChrW(&H441)&ChrW(&H20) & sResult
    End If
    '--- apply measure (use Measure:=vbNullString for none)
    If IsMissing(Measure) Then
        Measure = IIf(Val(vValue(0)) = 1, ChrW(&H43B)&ChrW(&H435)&ChrW(&H432), ChrW(&H43B)&ChrW(&H432)&ChrW(&H2E)) & ChrW(&H7C)&ChrW(&H441)&ChrW(&H442)&ChrW(&H2E)
        Gender = ChrW(&H4D)&ChrW(&H46)
    End If
    If LenB(Measure) <> 0 Then
        If Right$(sResult, Len(vDigits(0))) = vDigits(0) And Val(vValue(1)) <> 0 And InStr(Measure, ChrW(&H7C)) > 0 Then
            sResult = ToWords(IIf(dblValue < 0, -1, 1) * Val(vValue(1)), Split(Measure, ChrW(&H7C))(1), Mid$(Gender, 2))
        Else
            sResult = sResult & ChrW(&H20) & Split(Measure, ChrW(&H7C))(0)
            If Val(vValue(1)) <> 0 Or InStr(Measure, ChrW(&H7C)) > 0 Then
                sResult = sResult & ChrW(&H20)&ChrW(&H438)&ChrW(&H20) & vValue(1)
            End If
            If InStr(Measure, ChrW(&H7C)) > 0 Then
                sResult = sResult & ChrW(&H20) & Split(Measure, ChrW(&H7C))(1)
            End If
            sResult = UCase$(Left$(sResult, 1)) & Mid$(sResult, 2)
        End If
    End If
    ToWords = sResult
End Function

Public Function ToAllWords(ByVal dblValue As Double) As String
    ToAllWords = ToWords(Int(dblValue), ChrW(&H43B)&ChrW(&H432)&ChrW(&H2E)) & ChrW(&H20)&ChrW(&H438)&ChrW(&H20) & LCase$(ToWords(Round((dblValue - Int(dblValue)) * 100), ChrW(&H441)&ChrW(&H442)&ChrW(&H2E), ChrW(&H46)))
End Function

@staafl: LGTM във VBA работи.

Това за OpenOffice ли е полезно или по принцип и за VBA?

На последния мисля модулите му са Unicode и не би трябвало да има проблем с нормалните string литерали.

cheers,
</wqw>