poniedziałek, 16 marca 2009

Excel - zamienianie liczb na kwoty słownie

Otóż dziś znalazłem bardzo przydatny kod do makro w Excelu, który myślę przydać się może każdemu kto musi w Excelu np. stworzyć wzór druku KP, faktury czy wszelkiej innej dokumentacji wykorzystującej kwotę pisaną słownie. Excel nie zawiera takiej funkcji gotowej (moim zdaniem to wielka kicha). Należało więc stworzyć taki programik, który będzie umiał pobierać dane w postaci liczb/walut i w nowych komórkach wydać wynik w postaci słownej. Jak sami możecie sprawdzić makro działa na liczbach od -99 999.99 do 99 999.99 (no ale jeśli ktoś ma obroty większe, obraca większą gotówką, to pewnie stać go na profesjonalny program zamówiony u wyszkolonego informatyka, my szare żuczki musimy radzić sobie inaczej).

Tekst makro jest następujący:

Function Słownie(x As Variant) As String 'dla liczb od -99 999.99 do 99 999.99
If x < 0 Then w = w & "minus "
x = Format(Abs(x), "000 000 000.00"): m = Left(x, 3): t = Mid(x, 5, 3): j = Mid(x, 9, 3): g = "0" & Right(x, 2)
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
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
Select Case j
Case 0
If m = 0 And t = 0 Then w = w & "zero złotych " Else w = w & "złotych "
Case 1
If 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
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
x3 = Val(Left(x, 1)): x2 = Val(Mid(x, 2, 1)): x1 = Val(Right(x, 1))
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 "
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 "
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
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

I teraz jak to działa. Wchodzimy w Excela. Naciskamy skrót Alt+F11. Pojawia nam się okno do Visual Basic. Z menu górnego wybieramy Insert -> Module i wklejamy nasz kod. Zamykamy Visual Basica i teraz możemy uzyskiwać zamienianie wartości z wybranych komórek w nowych po wpisaniu =słownie(np. A5).

Do tego makra należy przypisać jakiś cyfrowy certyfikat bezpieczeństwa, ponieważ jak każde makro może zostać zatrzymane przez Excela po wyłączeniu i włączeniu programu. Ale rzecz przydatna. Ja sobie tekst tego kodu trzymam dla bezpieczeństwa w pliku .txt

Nie pamiętam jak się nazywał autor tego kodu, ale moim zdaniem stworzył coś bardzo przydatnego, co właściwie powinno być w standardowym Excelu.

20 komentarzy:

Dora pisze...

hej..
hmmm...ja tylko szukałam tłumaczenia Rare Bird "Sympathy"...choć dość proste, chyba bardziej niż to, co zawarłeś w tym poście..ale nie znalazłam...a teraz uciekam na mecz..chyba się "pośmiać" ;)

Anonimowy pisze...

super to makro :) dzięki wielkie. Działa rewelacyjnie.

Anonimowy pisze...

działa bez zarzutu. Dzięki!

Anonimowy pisze...

Człowieku - życie mi uratowałeś:) Świetne to makro. Dziękuję!!!!
Rosa

Anonimowy pisze...

super niewiele tak świetnych podpowiedzi dla laika Wiesław

Anonimowy pisze...

Bardzo dziękuję! Działa super!

Anonimowy pisze...

działa!! i to jak :) dzięki wielkie za ułatwienie "życia" exelowego :P

Anonimowy pisze...

jak dla mnie bomba. Oklaski dla autora

Anonimowy pisze...

Pojawia mi się error!Co robić???
Inka
Ale i tak dziękuję

Anonimowy pisze...

Działa bez zastrzeżeń. Dzięki dla autora.

Anonimowy pisze...

REWELEACJA !!!!!

Anonimowy pisze...

Super wszystko działa ok

Bea pisze...

Ślicznie działa:)dziękuję:)

Anonimowy pisze...

Strasznie się cieszymy. Makro działa wspaniale.

Anonimowy pisze...

Działa jak ta lala :) Dzięki ;)

Anonimowy pisze...

Można też bez VBA:
http://bajobongo.net/zerro/piotr/blog/show.php?f=1353128216
=USUŃ.ZBĘDNE.ODSTĘPY(JEŻELI(ZAOKR.DO.CAŁK(A1)=0;"zero";(...)
http://pastebin.com/Kw5MBLmX

Anonimowy pisze...

prima, super, wspaniale - dzięki!

Anonimowy pisze...

nareszcie znalazłam;) dzieki wielkie

Anonimowy pisze...

dzieki wielkie dziala super

Anonimowy pisze...

Polecam też mój sposób - tylko formuła, bez VBA: http://czterycztery.pl/programy/kwota_slownie.html