Skip to content

Instantly share code, notes, and snippets.

@wqweto
Last active October 27, 2020 09:07
  • Star 5 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
Star You must be signed in to star a gist
Embed
What would you like to do?
Конвертиране на число в словом с думи за VBA за Microsoft Excel. По подразбиране работи за левове в мъжки род, но може да се използва и за мярка в женски род (например метро единици) или среден род (например евро)
'=====================================================================================================================
'
' Конвертиране на число в словом с думи за 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
@jantadjer
Copy link

Прекрасен макрос, но допуска една грешка, може ли да я оправите
когато числото е -0,25 връща като словом "нула лв и двадесет и пет ст." Коректно е "минус двадесет и пет ст." Възможно ли да го оправите.
Освен това ако е възможно, винаги когато са само стотинки 0,25 да връша "двадесет и пет ст." а не както сега "нула лв и двадесет и пет ст.".
Благодаря предварително!

@jantadjer
Copy link

Моля и за още нещо - възможно ли е да се направи първата буква да не е главна, и когато няма стотинки 36,00 да изписва само "тридесет и шест лв" а не както сега " Тридесет и шест лв и 0 ст."

@wqweto
Copy link
Author

wqweto commented Dec 5, 2015

@jantadjer Мерси за bug report-а. Пипнах функцията като единствено не съм махнал да връща първа главна буква в резултата. Това може да се оправи с =LOWER(ToWords(A1)) във формулата на клетката примерно.

В момента тестовете връщат това:

Debug.Assert ToWords(0) = "Нула лв. и 00 ст."
    Debug.Assert ToWords(0.01) = "Една ст."
    Debug.Assert ToWords(0.25) = "Двадесет и пет ст."
    Debug.Assert ToWords(-0.25) = "Минус двадесет и пет ст."
    Debug.Assert ToWords(-0.25, "лв.") = "Минус нула лв. и 25"
    Debug.Assert ToWords(35) = "Тридесет и пет лв. и 00 ст."
    Debug.Assert ToWords(167.42) = "Сто шестдесет и седем лв. и 42 ст."
    Debug.Assert ToWords(-12341235) = "Минус дванадесет милиона триста четиридесет и една хиляди двеста тридесет и пет лв. и 00 ст."
    Debug.Assert ToWords(341.6, "МЕ|стотни", "FF") = "Триста четиридесет и една МЕ и 60 стотни"
    Debug.Assert ToWords(0.01, "МЕ|стотни", "FF") = "Една стотни"

Има лек проблем в последния тест (мн. ч. на стотни), който не смятам да оправям.

cheers,
</wqw>

@rboyadzhiev
Copy link

Здравейте и благодаря за кода :)
С много малка промяна го ползвам за vb.net и незнам само при мен ли е така

3125.00 : Три лв. хиляди сто двадесет и пет лв.
225.00 : Дваста двадесет и пет лв.

Благодаря предварително!

@wqweto
Copy link
Author

wqweto commented Mar 13, 2016

@rboyadzhiev: Нещо при портването се е забозило, защото при мене тези assert-и минават:

Debug.Assert ToWords(3125) = "Три хиляди сто двадесет и пет лв."
Debug.Assert ToWords(225) = "Двеста двадесет и пет лв."

Можеш да направиш fork и да качиш VB.Net версията в отделен gist да я погледна. Имай предвид че gist.github.com не праща email нотификация при нови коментари, освен ако не си настроиш външна услуга като https://giscus.co/ да ги наблюдава -- most recommended!

cheers,
</wqw>

@rboyadzhiev
Copy link

@wqweto
Copy link
Author

wqweto commented Mar 13, 2016

@rboyadzhiev: Fixed here https://gist.github.com/wqweto/d7ca68a5fd0368c08158

Добавил съм и тестовете.

cheers,
</wqw>

@rboyadzhiev
Copy link

Супер! Благодаря много :)

@hristo-atanasov
Copy link

Казвам го за всички които смятат да използват тази функцията за валути .. Да не се чудят какво става и защо сметките не излизат. Просто трябва да се промени форматирането на числото да е с 2 цифри след десетичната запетая.

@hristo-atanasov
Copy link

hristo-atanasov commented Jul 1, 2016

Хахахха ... Докато коментирам твоя код открих бъг в коментарите на github :D ...

Липсващата част от горното съобщение е:
Внимавайте с форматирането на подаваното число в случай, че функцията се изполва за валути - пример:
6806,292 изписва
Шест хиляди осемстотин и шест лв. и 292 ст.
292 ст. са 2,92 лв.
Желателно е да премахнете двата '##' от форматирането, за да не се получават такива проблеми.

@wqweto
Copy link
Author

wqweto commented Jul 4, 2016

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

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

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

cheers,
</wqw>

@andyon123
Copy link

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

@wqweto
Copy link
Author

wqweto commented Mar 1, 2017

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

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

@fluky6
Copy link

fluky6 commented Dec 6, 2017

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

@wqweto
Copy link
Author

wqweto commented Dec 6, 2017

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

cheers,
</wqw>

@vemilova
Copy link

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

@wqweto
Copy link
Author

wqweto commented Feb 15, 2018

Здравейте,

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

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

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

</wqw>

@zarkomm
Copy link

zarkomm commented May 25, 2018

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

@wqweto
Copy link
Author

wqweto commented May 26, 2018

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

cheers,
</wqw>

@BBPopov
Copy link

BBPopov commented May 31, 2019

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

@wqweto
Copy link
Author

wqweto commented May 31, 2019

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

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

cheers,
</wqw>

@BBPopov
Copy link

BBPopov commented Jun 1, 2019 via email

@staafl
Copy link

staafl commented Nov 28, 2019

Вариант на функцията с 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

@wqweto
Copy link
Author

wqweto commented Nov 28, 2019

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

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

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

cheers,
</wqw>

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment