Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Конвертиране на число в словом с думи за VBA за Microsoft Excel. По подразбиране работи за левове в мъжки род, но може да се използва и за мярка в женски род (например метро единици) или среден род (например евро)
'=====================================================================================================================
'
' Конвертиране на число в словом с думи за VBA за Microsoft Excel
' Copyright (c) 2012-2017 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

jassss commented Mar 14, 2013

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

Owner

wqweto commented Mar 14, 2013

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

zinaf commented May 14, 2013

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

onikolov commented Aug 4, 2014

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

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

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

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

Owner

wqweto commented Oct 21, 2015

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

cheers,
</wqw>

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

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

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>

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

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

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

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>

Owner

wqweto commented Mar 13, 2016

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

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

cheers,
</wqw>

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

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

hristo-atanasov commented Jul 1, 2016

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

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

Owner

wqweto commented Jul 4, 2016

@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 ли е или...?
Предварително благодаря!

Owner

wqweto commented Mar 1, 2017

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

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

fluky6 commented Dec 6, 2017

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

Owner

wqweto commented Dec 6, 2017

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

cheers,
</wqw>

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