Akademia VBA

czyli jak uzyskać władzę nad światem … danych

Odwieczny problem: Funkcja Slownie

Kategorie: Access VBA,Excel VBA,Uniwersalne VBA — Dariusz Kolasa o 13:38, 24 Kwi 2011

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

13 komentarzy »

21

Komentarz- kamilo_han

2 Wrz 2011 @ 10:39

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.).

22

Komentarz- Dariusz Kolasa

3 Wrz 2011 @ 21:08

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

65

Komentarz- adam

26 Mar 2014 @ 15:37

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]

Komentarz- nick

8 Kwi 2015 @ 13:56

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
:)

Komentarz- pallicho

28 Cze 2016 @ 12:38

Skorzystałem, dziękuję. Przydałaby się jeszcze wersja pod dowolną walutę typu:

sto jedenaście EUR 35/100.

Komentarz- Hulkij

29 Lip 2016 @ 7:45

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

Komentarz- Rafal

15 Sty 2018 @ 14:02

Chciałbym skorzystać z tego makra, ale niestety nie potrafię tego przenieść do mojego excela :(

Komentarz- Darek Kolasa

17 Sty 2018 @ 21:42

to może pomóc
http://akademia-vba.pl/ogolne/jak-skorzystac-z-kodu-vba-znalezionego-w-internecie/

Komentarz- Tomi

17 Paź 2018 @ 15:57

Może ktoś podpowiedzieć jak powyższy kod zaimplementować do sql-a?

Komentarz- sylwek

15 Lis 2018 @ 8:18

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 :)

Komentarz- Darek Kolasa

15 Lis 2018 @ 19:26

tak, wystarczy utworzyć skoroszyt z obsługą makr, w nim moduł publiczny i wkleić do niego kod
Pomoc:
http://akademia-vba.pl/excel-vba/jak-zaczac-programowanie-w-vba-w-excelu-2010/
http://akademia-vba.pl/ogolne/jak-skorzystac-z-kodu-vba-znalezionego-w-internecie/

Komentarz- Hobbit

19 Lis 2018 @ 8:23

Podpinam się pod kolegę. Jak stworzyć dopisek „zero groszy”?

Komentarz- Darek Kolasa

19 Lis 2018 @ 19:42

zmodyfikowałem kod – teraz będzie „zero groszy”

RSS komentarzy do wpisu. Adres trackback

Zostaw komentarz

Dozwolone znaczniki XHTML: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>