Create a gist now

Instantly share code, notes, and snippets.

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
@jassss

This comment has been minimized.

Show comment
Hide comment
@jassss

jassss Mar 14, 2013

Благодаря за интелигентно написания код!!!Виждал съм и други, но този е перфектен.Молбата ми е само да ми кажеш как да оправя да не ми изписва "дведесет", а "двадесет" и дали ти се намира същата функция за OpenOffice.Благодаря предварително!

jassss commented Mar 14, 2013

Благодаря за интелигентно написания код!!!Виждал съм и други, но този е перфектен.Молбата ми е само да ми кажеш как да оправя да не ми изписва "дведесет", а "двадесет" и дали ти се намира същата функция за OpenOffice.Благодаря предварително!

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Mar 14, 2013

@jassss: Оооопс, оправих го! Мерси за bug report-а

Owner

wqweto commented Mar 14, 2013

@jassss: Оооопс, оправих го! Мерси за bug report-а

@zinaf

This comment has been minimized.

Show comment
Hide comment
@zinaf

zinaf May 14, 2013

здравей, благодаря за кода.
имам обаче проблем, който не е пряко свързан с него, но поради това не мога да го ползвам. на ексел 2007, на английски, с регионални настройки на уиндоус7 на английски (UK), като paste-на кода във VBA кирилицата излиза като "?" знаци. какво трябва да променя, че да разпознае кирилицата. по принцип в ексел нямам проблем да пиша на кирилица.
Благодаря

zinaf commented May 14, 2013

здравей, благодаря за кода.
имам обаче проблем, който не е пряко свързан с него, но поради това не мога да го ползвам. на ексел 2007, на английски, с регионални настройки на уиндоус7 на английски (UK), като paste-на кода във VBA кирилицата излиза като "?" знаци. какво трябва да променя, че да разпознае кирилицата. по принцип в ексел нямам проблем да пиша на кирилица.
Благодаря

@onikolov

This comment has been minimized.

Show comment
Hide comment
@onikolov

onikolov Aug 4, 2014

Може ли да предложите подобна VBA програма за Word? Какво трябва да се промени, за да се използва?

Благодаря,
О. Николов

onikolov commented Aug 4, 2014

Може ли да предложите подобна VBA програма за Word? Какво трябва да се промени, за да се използва?

Благодаря,
О. Николов

@dimitrovr

This comment has been minimized.

Show comment
Hide comment
@dimitrovr

dimitrovr Apr 16, 2015

Здравей, кода е чудесен! Имаш ли код и за OpenOffice? Благодаря предварително!!!

Здравей, кода е чудесен! Имаш ли код и за OpenOffice? Благодаря предварително!!!

@roko2002

This comment has been minimized.

Show comment
Hide comment
@roko2002

roko2002 Sep 16, 2015

Здравейте, сега виждам този прекрасен код, но когато се опитам да сейвам файла, при повторно отваряне не работи. Моля за малко помощ

Здравейте, сега виждам този прекрасен код, но когато се опитам да сейвам файла, при повторно отваряне не работи. Моля за малко помощ

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Oct 21, 2015

@roko2002: Вижте дали настройка за защита от макроси в Excel е на Ниска или Средна стойност.

cheers,
</wqw>

Owner

wqweto commented Oct 21, 2015

@roko2002: Вижте дали настройка за защита от макроси в Excel е на Ниска или Средна стойност.

cheers,
</wqw>

@jantadjer

This comment has been minimized.

Show comment
Hide comment
@jantadjer

jantadjer Nov 2, 2015

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

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

@jantadjer

This comment has been minimized.

Show comment
Hide comment
@jantadjer

jantadjer Nov 2, 2015

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

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto 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>

Owner

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

This comment has been minimized.

Show comment
Hide comment
@rboyadzhiev

rboyadzhiev Mar 13, 2016

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

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

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

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

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

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto 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>

Owner

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>

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Mar 13, 2016

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

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

cheers,
</wqw>

Owner

wqweto commented Mar 13, 2016

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

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

cheers,
</wqw>

@rboyadzhiev

This comment has been minimized.

Show comment
Hide comment
@rboyadzhiev

rboyadzhiev Mar 13, 2016

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

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

@hristo-atanasov

This comment has been minimized.

Show comment
Hide comment
@hristo-atanasov

hristo-atanasov Jul 1, 2016

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

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

@hristo-atanasov

This comment has been minimized.

Show comment
Hide comment
@hristo-atanasov

hristo-atanasov Jul 1, 2016

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

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

hristo-atanasov commented Jul 1, 2016

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

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Jul 4, 2016

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

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

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

cheers,
</wqw>

Owner

wqweto commented Jul 4, 2016

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

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

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

cheers,
</wqw>

@andyon123

This comment has been minimized.

Show comment
Hide comment
@andyon123

andyon123 Mar 1, 2017

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

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Mar 1, 2017

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

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

Owner

wqweto commented Mar 1, 2017

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

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

@fluky6

This comment has been minimized.

Show comment
Hide comment
@fluky6

fluky6 Dec 6, 2017

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

fluky6 commented Dec 6, 2017

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Dec 6, 2017

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

cheers,
</wqw>

Owner

wqweto commented Dec 6, 2017

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

cheers,
</wqw>

@vemilova

This comment has been minimized.

Show comment
Hide comment
@vemilova

vemilova Feb 15, 2018

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

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto Feb 15, 2018

Здравейте,

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

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

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

</wqw>

Owner

wqweto commented Feb 15, 2018

Здравейте,

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

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

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

</wqw>

@zarkomm

This comment has been minimized.

Show comment
Hide comment
@zarkomm

zarkomm May 25, 2018

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

zarkomm commented May 25, 2018

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

@wqweto

This comment has been minimized.

Show comment
Hide comment
@wqweto

wqweto May 26, 2018

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

cheers,
</wqw>

Owner

wqweto commented May 26, 2018

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

cheers,
</wqw>

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