Chyba każdy program księgowy ma taką funkcjonalności, że potrafi zamienić liczbową reprezentację kwoty na jej reprezentację słowną, czyli przykładowo:

123, 45zł -> sto dwadzieścia trzy złote i czterdzieści pięć groszy

Jak to zrobić w Excelu? Potrzeba odpowiedni kod. Niestety nie jest znany mi jego autor, bo na żadnej stronie, gdzie go widziałem nikt nie wiedział kto go napisał. Mi on się bardzo podoba, bo jak się go odpowiednio podzieli jest naprawdę prosty do zrozumienia.
Ja żeby lepiej go zrozumieć dołożyłem do niego jeszcze część odpowiedzialną za przekształcenie miliardów.

Kod składa się z dwóch funkcji, które z komentarzami zamieszczam poniżej:

Function Słownie(x As Variant) As String 'dla liczb od -999 999 999 999.99 do 999 999 999 999.99
'Sprawdzamy czy podana kwota jest mniejsza od zera jeśli jest to dopisujemy do kwoty słownie słowo minus
If x < 0 Then w = w & "minus "

'Konwertujemy liczbę na zapis, który będzie pokazywał zawsze miliardy miliony, tysiące i jednostki
'nawet jeśli będą to same zera
x = Format(Abs(x), "000 000 000 000.00")
'części odpowiedzialne za miliardy, miliony itd. przypisujemy do oddzielnych zmiennych 3 cyfrowych
'wiodące zera również są w nich brane pod uwagę, a do groszy musimy dodać jedna zero na początku
'żeby później działało odpowiednio z funckją trzy
mld = Left(x, 3): m = Mid(x, 5, 3): t = Mid(x, 9, 3): j = Mid(x, 13, 3): g = "0" & Right(x, 2)

'Sprawdzamy miliardy i w zależności od ich ilości nadajemy inne końcówki
'analogicznie robimy z milionami, tysiącami, jednościami i groszami
Select Case mld
Case 0
Case 1
w = "jeden miliard "
Case Else
'za pomocą funkcji trzy sprawdzamy jaka jest liczba miliardów, a późniejszych częściach milionów itd.
w = w & trzy(mld)
'dodajemy odpowiedni "końcówek" na podstawie połączeniu odpowiednich warunków
If Mid(mld, 2, 1) <> 1 And (Right(mld, 1) = 2 Or Right(mld, 1) = 3 Or Right(mld, 1) = 4) Then w = w & "miliardy " Else w = w & "miliardów "
End Select

'Sprawdzanie milionów analogicznie jak miliardów
Select Case m
Case 0
Case 1
w = "jeden milion "
Case Else
w = w & trzy(m)
If Mid(m, 2, 1) <> 1 And (Right(m, 1) = 2 Or Right(m, 1) = 3 Or Right(m, 1) = 4) Then w = w & "miliony " Else w = w & "milionów "
End Select

'Sprawdzanie tysięcy analogicznie jak miliardów
Select Case t
Case 0
Case 1
w = w & "jeden tysiąc "
Case Else
w = w & trzy(t)
If Mid(t, 2, 1) <> 1 And (Right(t, 1) = 2 Or Right(t, 1) = 3 Or Right(t, 1) = 4) Then w = w & "tysiące " Else w = w & "tysięcy "
End Select

'Sprawdzanie jedności analogicznie jak miliardów
Select Case j
Case 0
If mld = 0 And m = 0 And t = 0 Then w = w & "zero złotych " Else w = w & "złotych "
Case 1
If mld = 0 And m = 0 And t = 0 Then w = w & "jeden złoty " Else w = w & "jeden złotych "
Case Else
w = w & trzy(j)
If Mid(j, 2, 1) <> 1 And (Right(j, 1) = 2 Or Right(j, 1) = 3 Or Right(j, 1) = 4) Then w = w & "złote " Else w = w & "złotych "
End Select

'sprawdzanie groszy analogicznie jak miliardów
Select Case g
Case 0
w = w '& "zero groszy"
Case 1
w = w & "jeden grosz"
Case Else
w = w & trzy(g)
If Mid(g, 2, 1) <> 1 And (Right(g, 1) = 2 Or Right(g, 1) = 3 Or Right(g, 1) = 4) Then w = w & "grosze" Else w = w & "groszy"
End Select

Słownie = w
End Function


Function trzy(x As Variant) As String
'dzielimy trzy cyfry na część odpowiedzialną za setki, dziesiątki i jedności
x3 = Val(Left(x, 1)): x2 = Val(Mid(x, 2, 1)): x1 = Val(Right(x, 1))
'Spradzamy jaka to setka
If x3 = 9 Then w = w & "dziewięćset "
If x3 = 8 Then w = w & "osiemset "
If x3 = 7 Then w = w & "siedemset "
If x3 = 6 Then w = w & "sześćset "
If x3 = 5 Then w = w & "pięćset "
If x3 = 4 Then w = w & "czterysta "
If x3 = 3 Then w = w & "trzysta "
If x3 = 2 Then w = w & "dwieście "
If x3 = 1 Then w = w & "sto "
'Sprawdzamy jaka to dziesiątka łącząc z ewentualną setką
If x2 = 9 Then w = w & "dziewięćdziesiąt "
If x2 = 8 Then w = w & "osiemdziesiąt "
If x2 = 7 Then w = w & "siedemdziesiąt "
If x2 = 6 Then w = w & "sześćdziesiąt "
If x2 = 5 Then w = w & "pięćdziesiąt "
If x2 = 4 Then w = w & "czterdzieści "
If x2 = 3 Then w = w & "trzydzieści "
If x2 = 2 Then w = w & "dwadzieścia "
'Sprawdzamy czy to nie jest nastka łącząc z ewentualną setką
If x2 = 1 Then
If x1 = 9 Then w = w & "dziewiętnaście "
If x1 = 8 Then w = w & "osiemnaście "
If x1 = 7 Then w = w & "siedemnaście "
If x1 = 6 Then w = w & "szesnaście "
If x1 = 5 Then w = w & "piętnaście "
If x1 = 4 Then w = w & "czternaście "
If x1 = 3 Then w = w & "trzynaście "
If x1 = 2 Then w = w & "dwanaście "
If x1 = 1 Then w = w & "jedenaście "
If x1 = 0 Then w = w & "dziesięć "
End If
'Sprawdzamy jaka to cyfra jedności i dołączamy do ewentualnej wcześniejszej części
If x2 <> 1 Then
If x1 = 9 Then w = w & "dziewięć "
If x1 = 8 Then w = w & "osiem "
If x1 = 7 Then w = w & "siedem "
If x1 = 6 Then w = w & "sześć "
If x1 = 5 Then w = w & "pięć "
If x1 = 4 Then w = w & "cztery "
If x1 = 3 Then w = w & "trzy "
If x1 = 2 Then w = w & "dwa "
If x1 = 1 Then w = w & "jeden "
End If
trzy = w
End Function

Pozdrawiam
Adam Kopeć
Miłośnik Excela
Microsoft MVP