-
-
Save wqweto/4118581 to your computer and use it in GitHub Desktop.
'===================================================================================================================== | |
' | |
' Конвертиране на число в словом с думи за 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 |
Здравейте,
Добавил съм втора едноредова функция ToAllWords
която работи винаги за левове/стотинки и последните са словом също.
За да я ползвате трябва повторно да си инсталирате модула, както е описано в инструкцията.
Ако не Ви устройва мерките да са лв.
и съответно ст.
можете да пробвате сами да си ги смените в ToAllWords
.
</wqw>
Може ли да го направиш да конвертира на английски.
@zarkomm: Не, в интернет е пълно с английски версии. Пробвай да потърсиш в google.
cheers,
</wqw>
Здравей, отдавна си мислих по проблема и добре, че жена ми ме светна за да се разровя в нета ;-))) Пробвах кода ти и работи чудесно за което искам и да ти благодаря! Само един въпрос. Защото гледам, че е имало допълнения и редакции на бъгове, този като последен вариант ли е? Страхотна работа и благодаря отново!
@BBPopov: Да, текущия код винаги е последната ревизия.
Най-горе има таб Revisions с 22
до него -- там са предишните версии ако нещо те интересува.
cheers,
</wqw>
Вариант на функцията с 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>
Здравейте, има ли как и цифрите след десетичната запетая да се изписват словом