Odwieczny problem: Funkcja Slownie

Jak na razie to największy kawałek kodu na tej stronie. Funkcja Slownie, czyli zamieniająca kwotę na jej słowny odpowiednik nie jest dostępna w Excelu ani w żadnej innej aplikacji Microsoft Office (o ile mi wiadomo).

I tu korekta (jak sądzę). W komentarzu pod tym artykułem znajduje się funkcja działająca w SQL Server Reporting Services. Komentarz autorstwa Pana Adama.

Oczywiście w Sieci można znaleźć wiele przykładów jej implementacji ale cóż warta byłaby strona o VBA, gdyby jej tu nie można było znaleźć. Wszelkie wytknięte błędy i konstruktywne uwagi krytyczne będą mile widziane (dwa błędy już zostały wykryte i poprawione). Funkcja korzysta z dwóch pomocniczych funkcji prywatnych, bez których nie będzie działać. Oto kod:

 
Option Explicit
 
Function Slownie(Kwota As Variant) As String
   '==================================
    ' UWAGA! Funkcja wymaga obu funkcji
    ' prywatnych zamieszczonych poniżej
    '==================================
 
    Const WERSJA As String = _
        "Funkcja Słownie v.1.02 (Akademia-VBA.pl)"
 
    Dim Opis(19) As String
    Dim DziesOpis(2 To 10) As String
    Dim SetOpis(1 To 9) As String
 
    Dim Zlotowki As String
    Dim Grosze As String
 
    Dim TrojkaZl As String
    Dim TrojkaTys As String
    Dim TrojkaMln As String
 
    Dim wynikGrosze As String
    Dim wynikZlote As String
    Dim Ujemna As Boolean
 
    On Error GoTo Obsluga
 
    'sprawdzenie czy puste
    If IsNull(Kwota) Or IsEmpty(Kwota) Then
        Slownie = "# Brak kwoty!"
        Exit Function
    End If
 
    'sprawdzenie czy liczba
    If Not IsNumeric(Kwota) Then
        Slownie = "# Nieprawidłowy typ wartości!"
        Exit Function
    End If
 
    'gdy ujemna
    If Kwota < 0 Then
        Ujemna = True
        Kwota = -Kwota
    End If
 
    'konwersja na stringi
    Zlotowki = CStr(Int(Kwota))
    Grosze = CStr(Kwota - Int(Kwota))
 
    'sprawdzenie, czy nie za duża, max 99 mln
    If Len(Zlotowki) > 9 Then
        Slownie = "# Kwota za duża, max 999 mln!"
        Exit Function
    End If
 
    'ewentualne zaokrąglenie do 2 msc po przecinku
    'tu drobna poprawka stąd wersja 1.01
    'było ...= CStr(Round(CDbl(Grosze) * 100, 2))
    If Len(Grosze) > 2 Then
        Grosze = CStr(Round(CDbl(Grosze), 2) * 100)
    End If
 
    'kod zasadniczy
    '==============
    Select Case Len(Zlotowki)
    Case 1 To 3
        wynikZlote = Trojka(Zlotowki) & _
            OpisRzeduWielkosci(CLng(Zlotowki), "zł", False)
    Case 4 To 6
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3)
        wynikZlote = Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    Case 7 To 9
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3)
        TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6)
        wynikZlote = Trojka(TrojkaMln) & _
            OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _
            & " " & Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    End Select
 
    wynikGrosze = Trojka(Grosze) & _
        OpisRzeduWielkosci(CLng(Grosze), "gr", False)
 
    If wynikGrosze = "" Then wynikGrosze = "zero groszy"
 
    Slownie = IIf(Ujemna, "minus ", "") & _
        Trim(wynikZlote & " " & wynikGrosze)
 
    Exit Function
Obsluga:
    MsgBox Err & " - " & Err.Description, vbCritical, WERSJA
End Function
 
Private Function OpisRzeduWielkosci( _
        Liczba As Long, RzadWielkosci As String, _
        WiekszeTysiac As Boolean) As String
 
    Dim JestZero As Boolean
    Dim DwieOstatnie As Long
    Dim Ostatnia As Long
 
    If Liczba = 0 Then
        If WiekszeTysiac Then
            If RzadWielkosci = "zł" Then
                OpisRzeduWielkosci = "złotych"
            End If
        Else
            OpisRzeduWielkosci = ""
        End If
        Exit Function
    End If
 
    DwieOstatnie = CLng(Right(CStr(Liczba), 2))
    Ostatnia = CLng(Right(CStr(Liczba), 1))
 
    Select Case RzadWielkosci
    Case "gr"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " groszy"
        Case 1
            OpisRzeduWielkosci = " grosz"
        Case 2 To 4
            OpisRzeduWielkosci = " grosze"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " groszy"
            Case 2 To 4
                OpisRzeduWielkosci = " grosze"
            End Select
        End Select
    Case "zł"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " złotych"
        Case 1
            OpisRzeduWielkosci = " złoty"
        Case 2 To 4
            OpisRzeduWielkosci = " złote"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " złotych"
            Case 2 To 4
                OpisRzeduWielkosci = " złote"
            End Select
        End Select
    Case "tys"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " tysięcy"
        Case 1
            OpisRzeduWielkosci = " tysiąc"
        Case 2 To 4
            OpisRzeduWielkosci = " tysiące"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " tysięcy"
            Case 2 To 4
                OpisRzeduWielkosci = " tysiące"
            End Select
        End Select
    Case "mln"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " milionów"
        Case 1
            OpisRzeduWielkosci = " milion"
        Case 2 To 4
            OpisRzeduWielkosci = " miliony"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " milionów"
            Case 2 To 4
                OpisRzeduWielkosci = " miliony"
            End Select
        End Select
    End Select
End Function
 
Private Function Trojka(strLiczba As String) As String
    Dim lngLiczba As Long
    Dim lngOstatnia As Long
    Dim lngDwieOstatnie As Long
 
    Dim Opis(19) As String
    Dim DziesOpis(10) As String
    Dim SetOpis(9) As String
 
    If CLng(strLiczba) = 0 Then
        Trojka = ""
        Exit Function
    End If
 
    Opis(0) = "zero"
    Opis(1) = "jeden"
    Opis(2) = "dwa"
    Opis(3) = "trzy"
    Opis(4) = "cztery"
    Opis(5) = "pięć"
    Opis(6) = "sześć"
    Opis(7) = "siedem"
    Opis(8) = "osiem"
    Opis(9) = "dziewięć"
    Opis(10) = "dziesięć"
    Opis(11) = "jedenaście"
    Opis(12) = "dwanaście"
    Opis(13) = "trzynaście"
    Opis(14) = "czternaście"
    Opis(15) = "piętnaście"
    Opis(16) = "szesnaście"
    Opis(17) = "siedemnaście"
    Opis(18) = "osiemnaście"
    Opis(19) = "dziewiętnaście"
 
    DziesOpis(0) = "zero"
    DziesOpis(1) = "dziesięć"
    DziesOpis(2) = "dwadzieścia"
    DziesOpis(3) = "trzydzieści"
    DziesOpis(4) = "czterdzieści"
    DziesOpis(5) = "pięćdziesiąt"
    DziesOpis(6) = "sześćdziesiąt"
    DziesOpis(7) = "siedemdziesiąt"
    DziesOpis(8) = "osiemdziesiąt"
    DziesOpis(9) = "dziewięćdziesiąt"
 
    SetOpis(0) = "zero"
    SetOpis(1) = "sto"
    SetOpis(2) = "dwieście"
    SetOpis(3) = "trzysta"
    SetOpis(4) = "czterysta"
    SetOpis(5) = "pięćset"
    SetOpis(6) = "sześćset"
    SetOpis(7) = "siedemset"
    SetOpis(8) = "osiemset"
    SetOpis(9) = "dziewięćset"
 
    lngLiczba = CLng(strLiczba)
 
    'tu policzymy ostatnią
    lngOstatnia = CLng(Right(strLiczba, 1))
 
    Select Case lngLiczba
    Case Is < 20
        Trojka = Opis(lngLiczba)
    Case Is < 100
        If lngLiczba Mod 10 = 0 Then
            Trojka = DziesOpis(lngLiczba / 10)
        Else
            Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _
                & " " & Opis(lngOstatnia)
        End If
    Case Else 'trzycyfrowa
        If lngLiczba Mod 100 = 0 Then
            Trojka = SetOpis(lngLiczba / 100)
        Else
            'tu policzymy dwie ostatnie
            lngDwieOstatnie = CLng(Right(strLiczba, 2))
 
            If lngLiczba Mod 10 = 0 Then
                Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                    & " " & DziesOpis(lngDwieOstatnie / 10)
            Else
                If lngDwieOstatnie < 20 Then
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & Opis(lngDwieOstatnie)
                Else
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _
                        & " " & Opis(lngOstatnia)
                End If
            End If
        End If
    End Select
End Function

39 myśli w temacie “Odwieczny problem: Funkcja Slownie

  1. OstLiczba = CLng(Right(CStr(Liczba), 1))

    W funkcji „OpisRzeduWielkosci” należy zmienić w powyższym fragmencie 1 na 2, ponieważ dla liczb większych niż 100 niepoprawnie odmienia słowo „złote” (bez zmiany otrzymujemy „113 złote”, „213 złote”, itd.).

    • witam mam problem po wklejeniu kodu wyskakuje mi blad
      SyntaxError: Unexpected identifier (wiersz 2, plik „makra.gs”)Zamknij

  2. rzeczywiście masz rację, odkryłeś błąd. Jego rozwiązanie nie było niestety aż tak proste jak proponowałeś, ale dzięki za testy. Zamieściłem już poprawiony kod

  3. Co prawda nie jest to VBA tylko VB.NET ale skoro Pan Adam tak się wysilił to może się komuś przyda funkcja Slownie na potrzeby SQL Server Reporting Services (jeszcze nie testowałem ale wygląda sensownie)
    Poniżej cytuję Pana Adama
    [cc lang=”vb”]
    Do reporting services funkcja do zamiany kwoty na słownie

    Public Shared Function changeToWords(ByVal numb As [String]) As [String]
    Dim val As [String] = „”, wholeNo As [String] = numb, points As [String] = „”, andStr As [String] = „”, pointStr As [String] = „”
    Dim endStr As [String] = „”
    Try
    Dim decimalPlace As Integer = numb.IndexOf(„.”)
    If decimalPlace > 0 Then
    wholeNo = numb.Substring(0, decimalPlace)
    points = numb.Substring(decimalPlace + 1)

    andStr = ” ”

    pointStr = translateCents(points)
    Else andStr = ” 00/100 zł”
    End If
    val = [String].Format(„{0} {1}{2} {3}”, translateWholeNumber(wholeNo).Trim(), andStr, pointStr, endStr)
    Catch

    End Try
    Return val
    End Function
    Private Shared Function translateWholeNumber(ByVal number As [String]) As [String]
    Dim word As String = „”
    Try
    Dim beginsZero As Boolean = False
    ‚tests for 0XX
    Dim isDone As Boolean = False
    ‚test if already translated
    Dim dblAmt As Double = (Convert.ToDouble(number))
    ‚if ((dblAmt > 0) && number.StartsWith(„0”))
    If dblAmt > 0 Then
    ‚test for zero or digit zero in a nuemric
    beginsZero = number.StartsWith(„0”)

    Dim numDigits As Integer = number.Length
    Dim pos As Integer = 0
    ‚store digit grouping
    Dim place As [String] = „”
    ‚digit grouping name:hundres,thousand,etc…
    Select Case numDigits
    Case 1
    ‚ones’ range
    word = ones(number)
    isDone = True
    Exit Select
    Case 2
    ‚tens’ range
    word = tens(number)
    isDone = True
    Exit Select
    Case 3
    ‚hundreds’ range
    word = sto(number)
    isDone = True
    Exit Select
    ‚thousands’ range
    Case 4, 5, 6
    pos = (numDigits Mod 4) + 1

    Select Case numDigits
    Case 4
    place = tysiac(number.Substring(0, 1),1)
    Exit Select
    Case 5
    place = tysiac(number.Substring(1, 1),0)
    Exit Select
    Case 6
    place = tysiac(number.Substring(2, 1),0)
    Exit Select

    End Select

    Exit Select
    ‚millions’ range
    Case 7, 8, 9
    pos = (numDigits Mod 7) + 1

    Select Case numDigits
    Case 7
    place = milion(number.Substring(0, 1),1)
    Exit Select
    Case 8
    place = milion(number.Substring(1, 1),0)
    Exit Select
    Case 9
    place = milion(number.Substring(2, 1),0)
    Exit Select

    End Select

    Exit Select
    Case 10
    ‚Billions’s range
    pos = (numDigits Mod 10) + 1
    place = ” miliard ”
    Exit Select
    Case Else
    ‚add extra case options for anything above Billion…
    isDone = True
    Exit Select
    End Select
    If Not isDone Then
    ‚if transalation is not done, continue…(Recursion comes in now!!)
    word = translateWholeNumber(number.Substring(0, pos)) + place + translateWholeNumber(number.Substring(pos))
    ‚check for trailing zeros
    If beginsZero Then
    word = ” and ” & word.Trim()
    End If
    End If
    ‚ignore digit grouping names
    If word.Trim().Equals(place.Trim()) Then
    word = „”
    End If
    End If
    Catch

    End Try
    Return word.Trim()
    End Function

    Private Shared Function tysiac(ByVal digit As Integer, ByVal No As Integer) As [String]
    Dim name As [String] = Nothing
    Select Case digit
    Case 1
    If No.Equals(1) Then
    name = ” tysiąc ”
    Else
    name = ” tysiecy ”
    End If
    Exit Select
    Case 2, 3, 4
    name = ” tysiące ”
    Exit Select
    Case 5,6,7,8,9
    name = ” tysięcy ”
    Exit Select
    End Select
    Return name
    End Function

    Private Shared Function milion(ByVal digit As Integer, ByVal No As Integer) As [String]
    Dim name As [String] = Nothing
    Select Case digit
    Case 1
    If No.Equals(1) Then
    name = ” milion ”
    Else
    name = ” milionów ”
    End If
    Exit Select
    Case 2, 3, 4
    name = ” miliony ”
    Exit Select
    Case 5,6,7,8,9
    name = ” milionów ”
    Exit Select
    End Select
    Return name
    End Function

    Private Shared Function sto(ByVal digit As [String]) As [String]
    Dim digt As Integer = Convert.ToInt32(digit)
    Dim name As [String] = Nothing
    Select Case digt
    Case 100
    name = „sto”
    Exit Select
    Case 200
    name = „dwieście”
    Exit Select
    Case 300
    name = „trzysta”
    Exit Select
    Case 400
    name = „czterysta”
    Exit Select
    Case 500
    name = „pięćset”
    Exit Select
    Case 600
    name = „sześćset”
    Exit Select
    Case 700
    name = „siedemset”
    Exit Select
    Case 800
    name = „osiemset”
    Exit Select
    Case 900
    name = „dziewięćset”
    Exit Select
    Case Else
    If digt > 0 Then
    name = (sto(digit.Substring(0, 1) & „00”) & ” „) + (tens(digit.Substring(1, 1) & „0”) & ” „) + ones(digit.Substring(2))
    End If
    Exit Select
    End Select
    Return name
    End Function

    Private Shared Function tens(ByVal digit As [String]) As [String]
    Dim digt As Integer = Convert.ToInt32(digit)
    Dim name As [String] = Nothing
    Select Case digt
    Case 10
    name = „dziesięć”
    Exit Select
    Case 11
    name = „jedenaście”
    Exit Select
    Case 12
    name = „dwanaście”
    Exit Select
    Case 13
    name = „trzynaście”
    Exit Select
    Case 14
    name = „czternaście”
    Exit Select
    Case 15
    name = „piętnaście”
    Exit Select
    Case 16
    name = „szesnaście”
    Exit Select
    Case 17
    name = „siedemnaście”
    Exit Select
    Case 18
    name = „osiemnaście”
    Exit Select
    Case 19
    name = „dziewiętnaście”
    Exit Select
    Case 20
    name = „dwadzieścia”
    Exit Select
    Case 30
    name = „trzydzieści”
    Exit Select
    Case 40
    name = „czterdzieści”
    Exit Select
    Case 50
    name = „pięćdziesiąt”
    Exit Select
    Case 60
    name = „sześćdziesiąt”
    Exit Select
    Case 70
    name = „siedemdziesiąt”
    Exit Select
    Case 80
    name = „osiemdziesiąt”
    Exit Select
    Case 90
    name = „dziewięćdziesiąt”
    Exit Select
    Case Else
    If digt > 0 Then
    name = (tens(digit.Substring(0, 1) & „0”) & ” „) + ones(digit.Substring(1))
    End If
    Exit Select
    End Select
    Return name
    End Function
    Private Shared Function ones(ByVal digit As [String]) As [String]
    Dim digt As Integer = Convert.ToInt32(digit)
    Dim name As [String] = „”
    Select Case digt
    Case 1
    name = „jeden”
    Exit Select
    Case 2
    name = „dwa”
    Exit Select
    Case 3
    name = „trzy”
    Exit Select
    Case 4
    name = „cztery”
    Exit Select
    Case 5
    name = „pięć”
    Exit Select
    Case 6
    name = „sześć”
    Exit Select
    Case 7
    name = „siedem”
    Exit Select
    Case 8
    name = „osiem”
    Exit Select
    Case 9
    name = „dziewięć”
    Exit Select
    End Select
    Return name
    End Function
    Private Shared Function translateCents(ByVal cents As [String]) As [String]
    Dim cts As [String] = „”, digit As [String] = „”, engOne As [String] = „”

    For i As Integer = 0 To cents.Length – 1
    digit = cents(i).ToString()
    cts += „” & digit
    Next

    If cents.Length.Equals(1) Then
    cts += „0”
    End If

    If cents.Length.Equals(0) Then
    cts += „00”
    End If

    cts += „/100 zł”
    Return cts
    End Function
    [/cc]

  4. taki drobiazg 🙂

    debug.Print Slownie(999999999.-1)
    dziewięćset dziewięćdziesiąt dziewięć milionów dziewięćset dziewięćdziesiąt dziewięć tysięcy dziewięćset dziewięćdziesiąt osiem złotych
    🙂

  5. Cześć,
    czy w jakiś prosty sposób da się zamienić by do kwoty, którą jest liczba całkowita było dopisywane „zero groszy”.
    Czy da zmienić się zapis groszy na format „gr/100”?
    Kod, który jest na tej stronie jest bardzo dobrej jakości w porównaniu do tych zamieszczonych przez innych użytkowników, natomiast brakuje mi tej opcji.
    Pozdrawiam

  6. Witam, czy wystarczy skopiować kod i wkleić w edytorze vba żeby działał? Wklejam wszystko w jeden moduł i nie działa, zamiast wyniku wyswietla mi sie #Błąd ;/ Proszę o pomoc 🙂

  7. Kod się sprawdza doskonale. Bardzo mi pomógł i dziękuję twórcy za udostępnienie. Od razu dodam, że w momencie, gdy zaczął go obsługiwać pechowiec, czyli ja 😀 od razu wyskoczył mi byk. Oczywiście mój, na który ewidentnie twórca nie był przygotowany 😀 Nie wprowadziłam zaokrągleń kwot, więc wynik formuły był dokładnie 179.9989. Funkcja wówczas podaje wartość słownie „sto siedemdziesiąt dziewięć złotych i sto groszy”… Może warto wprowadzić zaporę przed zdolnościami takich, jak ja 😀

  8. Super funkcja, bardzo dziękuje.
    Ja również mam problem, kwota 1100,00 słownie brzmi „jeden tysiąc dziewięćdziesiąt dziewięć złoty sto groszy”.
    da się to jakoś poprawić?

  9. Witam, u mnie po zaimplementowaniu kodu i próbie użycia, pojawia się błąd. Na nowo otwiera się okno VBA i prosi o poprawę tego fragmentu:

    ‚gdy ujemna
    If Kwota < 0 Then

  10. witam mam problem po wklejeniu kodu wyskakuje mi blad
    SyntaxError: Unexpected identifier (wiersz 2, plik „makra.gs”)Zamknij

  11. Witam,

    szukam kodu do kwoty słownie ale aby grosze były 35/100 gdzie mogę to znaleźć
    prosiłabym o udostępnienie go bo kurcze mam ten drugi

  12. Witam, czy mogłabym prosić kod dotyczący zapisu liczby w formie słownej ale żeby było 12/100 – taka forma tylko mnie interesuje

    z góry będę bardzo wdzięczna

  13. Dzień dobry,
    Czy posiada Pan zamianę liczb na tekst w wersji angielskiej ewentualnie podpowiedź gdzie znaleźć.
    Z góry dziękuję
    Rysiek

  14. Dzień dobry. Robię tak jak jest napisane. I co dziwne w niektórych plikach działa. Natomiast w innych pojawia się błąd #ADR!
    Jaka może być tego przyczyna?

    • no po prostu błąd adresowania, funkcja nie ma z tym nic wspólnego, każesz Excelowi użyć adresu, który nie jest prawidłowy w danym kontekście. Poczytaj o adresowaniu w Excelu, jest tego multum w necie

  15. Witam.
    W MS Excel 2007 wszystko działa poprawnie, lecz podczas przeniesienia do darmowej wersji Office – LibreOffice jest problem.
    Wyrzuca komunikat „Błąd uruchomieniowy języka BASIC. Nie ustawiono zmiennej obiektu”. Dzieje się tak jedynie podczas „konwertowania” liczb po przecinku (groszy). Podczas „konwertowania” samych złotówek jest poprawnie.

  16. Ćwiczenie ex-855 – chodzi mi przy wyświetlaniu liczby słownie wyświetla i daje liczbę ułamkową tylko po liczbie słownie żeby pisało złotych i po liczbie ułamkowej grosze

  17. Dzień dobry. Mam problem z wrzuceniem danego skryptu do arkuszy kalkulacyjnych google. Wyskakuje non stop ” SyntaxError: Unexpected identifier (wiersz 2, plik „kod.gs”) „- jest to wiersz zawierający jedynie Option Explicit. Czy da się jakoś rozwiązać dany problem?

Dodaj komentarz

Twój adres email nie zostanie opublikowany. Pola, których wypełnienie jest wymagane, są oznaczone symbolem *