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.

Skoki narciarskie gierka flash

Otóż od kilku dni nie mogę oderwać się od niby prostej gierki flashowej. Ale każdy pobity rekord przytrzymuje mnie przy tej grze dłużej

Lista moich rekordów stopniowo rosła. Najpierw ledwo skoczyłem 115 m. Potem 119,5 i potem długo długo nie mogłem przekroczyć magicznej liczby 120m. W końcu jak już walnąłem to 124 m, potem od razu 127,5 a potem męczyłem się długo by skoczyć 128 m. W tej samej rozgrywce jednak... udało mi się skoczyć 129,5 m a zaraz potem skoczyć 130 ale nie ustane... Cały dzień próbowałem w wolnych chwilach przebić ten rekord i w końcu udało się. Jest granica 130 metrów pobita

na dowód screen:



Jeśli ktoś chce się spróbować na tej skoczni proszę oto adres:
http://www.cda.pl/gry-online/3/skoki.php

Jeśli skoczysz więcej niż 131 metrów daj mi znać w komentarzu i podaj linka do screena ;)