Skip to content

Instantly share code, notes, and snippets.

@wqweto
Last active October 27, 2020 09:07
Show Gist options
  • Save wqweto/4118581 to your computer and use it in GitHub Desktop.
Save wqweto/4118581 to your computer and use it in GitHub Desktop.
Конвертиране на число в словом с думи за 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
@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