Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.

[Excel] Promjena makroa za ispisivanje brojeva slovima. How?

[es] :: Office :: Excel :: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?

Strane: 1 2 3

[ Pregleda: 27391 | Odgovora: 40 ] > FB > Twit

Postavi temu Odgovori

Autor

Pretraga teme: Traži
Markiranje Štampanje RSS

Slobodan Trebovac
Banja Luka

Član broj: 40266
Poruke: 1088
*.teol.net.



+1 Profil

icon [Excel] Promjena makroa za ispisivanje brojeva slovima. How?05.01.2006. u 11:40 - pre 221 meseci
Nedavno sam na sajtu http://www.praktikum.co.yu/ pronasao makro za Excel napisan u VBA koji upisani broj pretvara u slova. Navedeno je da makro radi radi u svim verzijama Excela pocev od Excela 5 do Excela 2000. Posto u vrijeme kada je to objavljeno vjerovatno nisu postojale novije verzije ja sam provjerio i na novijim verzijama Excela i navedeni makro radi i na njima, zakljucno sa Excel-om 2003. Makro radi besprijekorno. E sad ja hocu da malo izmijenim rezultat koji daje makro, ali posto sam jos uvijek na vi sa VBA, zamolio bih nekoga ko zna da pokusa da malo izmijeni kod makro-a da bi davao rezultat koji bih ja zelio, a mislim da je to veoma koristan makro koji moze koristiti mnogima.
Znaci, VBA makro daje ovakav rezultat:
npr.
dvijestotinesedamdesetpet 14/100

a mene interesuje da li moze ovako:
Dvijestotinesedamdesetpet i 14/100 DIN


Evo dajem i makro:

Code:

Function slovima(broj)

If broj = 0 Then rez = "nula"

ReDim imebr(9)
imebr(1) = "jedan"
imebr(2) = "dva"
imebr(3) = "tri"
imebr(4) = "četiri"
imebr(5) = "pet"
imebr(6) = "šest"
imebr(7) = "sedam"
imebr(8) = "osam"
imebr(9) = "devet"

rez = ""
celi = Int(broj)
dec = ((broj - celi) * 100) Mod 100
cbr = Str(celi)
duzina = 16 - Len(cbr)
cbroj = String(duzina, "0") & Right(cbr, Len(cbr) - 1)

i = 1

Do While i < 15
 tric = Mid(cbroj, i, 3)
 trojka = Val(tric)
 If tric <> "000" Then
  cs = Val(Mid(tric, 1, 1))
  cd = Val(Mid(tric, 2, 1))
  cj = Val(Mid(tric, 3, 1))
  Select Case cs
   Case 2
    rez = rez & "dve"
   Case Is > 2
    rez = rez & imebr(cs)
  End Select

  Select Case cs
   Case 1
    rez = rez & "stotinu"
   Case 2, 3, 4
    rez = rez & "stotine"
   Case Is > 4
    rez = rez & "stotina"
  End Select

  If cj = 0 Then sl1 = "" Else sl1 = imebr(cj)

  Select Case cd
   Case 4
    rez = rez & "četr"
   Case 6
    rez = rez & "šez"
   Case 5
    rez = rez & "pe"
   Case 9
    rez = rez & "deve"
   Case 2, 3, 7, 8
    rez = rez & imebr(cd)
   Case 1
    sl1 = ""
    Select Case cj
     Case 0
      rez = rez & "deset"
     Case 1
      rez = rez & "jeda"
     Case 4
      rez = rez & "četr"
     Case Else
      rez = rez & imebr(cj)
    End Select
   If cj > 0 Then rez = rez & "naest"
  End Select

  If cd > 1 Then rez = rez & "deset"

  If (i = 4 Or i = 10) And cd <> 1 Then
   If cj = 1 Then
    sl1 = "jedna"
   ElseIf cj = 2 Then
    sl1 = "dve"
   End If
  End If

  rez = rez & sl1

  Select Case i

   Case 1
    rez = rez & "bilion"
    If cj > 1 Or cd = 1 Then rez = rez & "a"

   Case 4
    rez = rez & "milijard"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Then
     rez = rez & "i"
    ElseIf cj = 1 Then
     rez = rez & "a"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "i"
    ElseIf cj > 1 Then
     rez = rez & "e"
    End If

   Case 7
    rez = rez & "milion"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj <> 1 Then
     rez = rez & "a"
    End If

   Case 10
    rez = rez & "hiljad"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj = 1 Then
     rez = rez & "a"
    ElseIf trojka = 1 Then
     rez = rez & "u"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "a"
    ElseIf cj > 1 Then
     rez = rez & "e"
    End If

  End Select
 End If
 i = i + 3
Loop

slovima = rez & Str(dec) & "/100"

End Function



I jos me jedna stvar interesuje, kako natjerati makro da prikazuje slovo č jer umjesto četiri on napise cetiri.
Hvala.

[Ovu poruku je menjao Shadowed dana 13.05.2006. u 18:48 GMT+1]
tyranBL
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
212.200.27.*

Sajt: www.gowi.rs


+109 Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?05.01.2006. u 13:30 - pre 221 meseci
Zameni poslednji red (iza Loop) sa sledećim:

rez = UCase(Left(rez, 1)) & Right(rez, Len(rez) - 1)
slovima = rez & Str(dec) & "/100" & " DIN"

Što ste tiče problema sa č nisam siguran da to nije radilo i ovako - koristio sam i sam ovu funkciju, ali može se staviti ChrW(269) dakle izmeni redove

imebr(4) = ChrW(269) + "etiri"

i ispod Case 4:

rez = rez & ChrW(269) + "etr"




Nije to loše Rembrante, samo što ne bi dodao još malo boje?
 
Odgovor na temu

Slobodan Trebovac
Banja Luka

Član broj: 40266
Poruke: 1088
*.teol.net.



+1 Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?07.01.2006. u 00:37 - pre 221 meseci
To je to, sad je sve kao sto ja zelim.
Hvala.
tyranBL
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 11:20 - pre 219 meseci
Moze jos jedna mala dorada:

Kako napraviti da se prikazuje: "Dvijestotinesedamdesetpet i 00/100 DIN" ? Znaci ako je iznos 275,00 DIN da dobijem prethodno navedeni ispis?
Hvala
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
212.200.27.*

Sajt: www.gowi.rs


+109 Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 12:13 - pre 219 meseci
Ako umesto funkcije str(dec) napišeš format(dec, "00")
dobićeš to što želiš i svi jednocifreni iznosi pisaće se sa 0 ispred -- 05/100 umesto 5/100 itd.
Nije to loše Rembrante, samo što ne bi dodao još malo boje?
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 13:08 - pre 219 meseci
Odlicno, hvala.

Jos me zanima kako da, kada se upise 0,15 DIN iznos ispise kao: nula DIN i 15/100?

A jel' mozda znas i imas vremena doraditi taj kod da se i te pare ispisuju slovima?

Hvala jos jednom
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 13:25 - pre 219 meseci
Citat:
Jos me zanima kako da, kada se upise 0,15 DIN iznos ispise kao: nula DIN i 15/100?


Ovo sam rjesio.

Ako mozes/stignes ono drugo .. :)

Hvala
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
212.200.27.*

Sajt: www.gowi.rs


+109 Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 14:32 - pre 219 meseci
Da ne bi mnogo brljao postojeci kod (usput iako ovde nije navedeno kod je ' beerware' - vidi sajt praktikum.co.yu) napravio sam novu funkciju, koju treba dodati umesto format - slovima = rez & "dinara i " & slovimapare(dec). Nova funkcija koristi istu logiku.

Code:

Function slovimapare(broj) As String
' konvertuje broj do 99 u tekst
 
 Dim cBroj As String
 ReDim imebr(9)
 imebr(1) = "jedan"
 imebr(2) = "dva"
 imebr(3) = "tri"
 imebr(4) = ChrW(269) & "etiri"
 imebr(5) = "pet"
 imebr(6) = "šest"
 imebr(7) = "sedam"
 imebr(8) = "osam"
 imebr(9) = "devet"
 
 cBroj = Format(broj, "00")
 
 cd = Val(Mid(cBroj, 1, 1))
 cj = Val(Mid(cBroj, 2, 1))
 
 If broj = 0 Then
    slovimapare = "nula para"
    GoTo Kraj
 End If
 
 If cj = 0 Then sl1 = "" Else sl1 = imebr(cj)
 
 Select Case cd
   Case 4
    rez = rez & ChrW(269) & "etr"
   Case 6
    rez = rez & "šez"
   Case 5
    rez = rez & "pe"
   Case 9
    rez = rez & "deve"
   Case 2, 3, 7, 8
    rez = rez & imebr(cd)
   Case 1
    sl1 = ""
    Select Case cj
     Case 0
      rez = rez & "deset"
     Case 1
      rez = rez & "jeda"
     Case 4
      rez = rez & ChrW(269) & "etr"
     Case Else
      rez = rez & imebr(cj)
    End Select
   If cj > 0 Then rez = rez & "naest"
  End Select

  If cd > 1 Then rez = rez & "deset"

  If cd <> 1 Then
   If cj = 1 Then
    sl1 = "jedna"
   ElseIf cj = 2 Then
    sl1 = "dve"
   End If
  End If

  rez = rez & sl1 & "par"
  
  If cj >= 2 And cj <= 4 And cd <> 1 Then
    rez = rez & "e"
  Else
    rez = rez & "a"
  End If
  slovimapare = rez


Kraj:
End Function


Nije to loše Rembrante, samo što ne bi dodao još malo boje?
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.adsl.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 18:30 - pre 219 meseci
Molim te malo pojasnjenje: da li tu funkciju kopiram u isti modul iza Loop pa na kraju dodam ono slovima = rez & "dinara i " & slovimapare(dec) ili ju kopiram u novi modul ili nesto trece?

Hvala
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.adsl.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?29.03.2006. u 18:42 - pre 219 meseci
Ma sve OK. Insertirao sam novi Modul, a u prethodnom iymjenio red sa slovima ......

Jos jednom - hvala ti puno.
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?30.03.2006. u 07:46 - pre 219 meseci
Jos jedno pitanje:

Testirajuci malo ovu funkciju primjetio sam da kada se upise npr. -0,25 rezultat je nula dinara i dvije pare umjesto dvadesetpet para

Imas li rjesenje za ovaj problem?
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
212.200.27.*

Sajt: www.gowi.rs


+109 Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?30.03.2006. u 15:16 - pre 219 meseci
Kod mene radi OK za pozitivne brojeve npr 0.25 dobija se nuladinaraidvadesetpetpara.
Za negativne brojeve ovo ne radi. Znači prethodno ispitaj da li je negativa pa ga pretvori u pozitivan i dodaj neki tekst direktno u Excelu - ne treba da menjaš makro.
Nije to loše Rembrante, samo što ne bi dodao još malo boje?
Prikačeni fajlovi
 
Odgovor na temu

7DaDo7

Član broj: 47388
Poruke: 17
*.net.t-com.hr.



Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?31.03.2006. u 06:18 - pre 219 meseci
Nazalost meni to nije tako jednostavno /mislim na svoje (ne)znanje/ :(

Naime ona prva funkcija na neki (meni nepoznat) nacin ignorira predznak odnosno da li je broj pozitivan ili negativan jer ako upises 100,00 ili -100,00 dobije s rezultat "sto"
A meni bas upravo to i treba. Ove funkcije bi koristio na obrascu fakture, a s obzirom da ponekad moram raditi i storno fakture (iznosi kao i na racunu koji se stornira, ali svi negativni "-") iznos bi se neovisno o predznaku trebao ipravno ispisivati.

Jel' se moze to nekako napraviti i u tvojoj funkciji?

Hvala na trudu.
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
212.200.27.*

Sajt: www.gowi.rs


+109 Profil

icon Re: Promjena makroa za ispisivanje brojeva slovima. How?31.03.2006. u 07:31 - pre 219 meseci
Jednostavno u Excelu nemoj da direktno pozoveš funkciju slovima(iznos) nego:
Code:
 =IF(B1>= 0;slovima(B1);slovima(-B1))


U prilogu koji sam prethodno poslao B1 sadrzi iznos, ti naravno promeni.
Nije to loše Rembrante, samo što ne bi dodao još malo boje?
 
Odgovor na temu

VralE
Jande Jo
IT sluzba
Bojdo

Član broj: 39992
Poruke: 8
*.teol.net.



Profil

icon Re: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?27.03.2008. u 09:16 - pre 194 meseci
Evo prepravljena verzija na ijekavici i u konvertibilnim markama.





Code:


Function slovima(broj)

If broj = 0 Then rez = "nula"

ReDim imebr(9)
imebr(1) = "jedna"
imebr(2) = "dvije"
imebr(3) = "tri"
imebr(4) = ChrW(269) + "etiri"
imebr(5) = "pet"
imebr(6) = "šest"
imebr(7) = "sedam"
imebr(8) = "osam"
imebr(9) = "devet"

rez = ""
celi = Int(broj)
dec = ((broj - celi) * 100) Mod 100
cbr = Str(celi)
duzina = 16 - Len(cbr)
cbroj = String(duzina, "0") & Right(cbr, Len(cbr) - 1)

i = 1

Do While i < 15
 tric = Mid(cbroj, i, 3)
 trojka = Val(tric)
 If tric <> "000" Then
  cs = Val(Mid(tric, 1, 1))
  cd = Val(Mid(tric, 2, 1))
  cj = Val(Mid(tric, 3, 1))
  Select Case cs
   Case 2
    rez = rez & "dvije"
   Case Is > 2
    rez = rez & imebr(cs)
  End Select

  Select Case cs
   Case 1
    rez = rez & "stotinu"
   Case 2, 3, 4
    rez = rez & "stotine"
   Case Is > 4
    rez = rez & "stotina"
  End Select

  If cj = 0 Then sl1 = "" Else sl1 = imebr(cj)

  Select Case cd
   Case 4
    rez = rez & ChrW(269) + "etr"
   Case 6
    rez = rez & "šez"
   Case 5
    rez = rez & "pe"
   Case 9
    rez = rez & "deve"
   Case 2
    rez = rez & "dva"
    Case 3, 7, 8
    rez = rez & imebr(cd)
   Case 1
    sl1 = ""
    Select Case cj
     Case 0
      rez = rez & "deset"
     Case 1
      rez = rez & "jeda"
     Case 2
      rez = rez & "dva"
     Case 4
      rez = rez & ChrW(269) + "etr"
     Case Else
      rez = rez & imebr(cj)
    End Select
   If cj > 0 Then rez = rez & "naest"
  End Select

  If cd > 1 Then rez = rez & "deset"

  If (i = 4 Or i = 10) And cd <> 1 Then
   If cj = 1 Then
    sl1 = "jedna"
   ElseIf cj = 2 Then
    sl1 = "dvije"
   End If
  End If

  rez = rez & sl1

  Select Case i

   Case 1
    rez = rez & "bilion"
    If cj > 1 Or cd = 1 Then rez = rez & "a"

   Case 4
    rez = rez & "milijard"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Then
     rez = rez & "i"
    ElseIf cj = 1 Then
     rez = rez & "a"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "i"
    ElseIf cj > 1 Then
     rez = rez & "e"
    End If

   Case 7
    rez = rez & "milion"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj <> 1 Then
     rez = rez & "a"
    End If

   Case 10
    rez = rez & "hiljad"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj = 1 Then
     rez = rez & "a"
    ElseIf trojka = 1 Then
     rez = rez & "u"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "a"
    ElseIf cj > 1 Then
     rez = rez & "e"
    End If

  End Select
 End If
 i = i + 3
Loop

slovima = rez & Format(dec, " i 00") & "/100" & " KM"

End Function


 
Odgovor na temu

omega009
kompj. adm.
skopje, makedonija

Član broj: 218226
Poruke: 12
77.28.38.*



Profil

icon Re: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?24.08.2009. u 10:36 - pre 177 meseci
Dali nekoj, slucajno, go ima odraboteno ovoj cod na makedonski?

Pozz.



[Ovu poruku je menjao omega009 dana 25.08.2009. u 08:07 GMT+1]
What doesn't kill me, costs me money!
 
Odgovor na temu

omega009
kompj. adm.
skopje, makedonija

Član broj: 218226
Poruke: 12
77.28.34.*



Profil

icon Re: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?28.09.2009. u 10:00 - pre 176 meseci
Eve ja verzijata na ovoj cod na makedonski jazik:
Code:

Function slovima(broj)

If broj = 0 Then rez = "nula"

ReDim imebr(9)
imebr(1) = "eden"
imebr(2) = "dva"
imebr(3) = "tri"
imebr(4) = "~etiri"
imebr(5) = "pet"
imebr(6) = "{est"
imebr(7) = "sedum"
imebr(8) = "osum"
imebr(9) = "devet"

rez = ""
celi = Int(broj)
dec = ((broj - celi) * 100) Mod 100
cbr = Str(celi)
duzina = 16 - Len(cbr)
cBroj = String(duzina, "0") & Right(cbr, Len(cbr) - 1)

i = 1

Do While i < 15
 tric = Mid(cBroj, i, 3)
 trojka = Val(tric)
 If tric <> "000" Then
  cs = Val(Mid(tric, 1, 1))
  cd = Val(Mid(tric, 2, 1))
  cj = Val(Mid(tric, 3, 1))
  Select Case cs
   Case 2
    rez = rez & "dve"
   Case Is > 2
    rez = rez & imebr(cs)
  End Select

  Select Case cs
   Case 1
    rez = rez & "sto"
   Case 2
    rez = rez & "ste"
   Case 3
    rez = rez & "sta"
   Case 2, 3, 4
    rez = rez & "stotini"
   Case Is > 4
    rez = rez & "stotini"
  End Select

  If cj = 0 Then sl1 = "" Else sl1 = imebr(cj)

  Select Case cd
   Case 4
    rez = rez & "~etiri"
   Case 6
    rez = rez & "{e"
   Case 5
    rez = rez & "ped"
   Case 7
    rez = rez & "sedumd"
   Case 8
    rez = rez & "osumd"
   Case 9
    rez = rez & "deved"
   Case 2, 3, 7, 8
    rez = rez & imebr(cd)
   Case 1
    sl1 = ""
    Select Case cj
     Case 0
      rez = rez & "deset"
     Case 1
      rez = rez & "edi"
     Case 4
      rez = rez & "~etiri"
     Case Else
      rez = rez & imebr(cj)
    End Select
   If cj > 0 Then rez = rez & "naeset"
  End Select

  If cd > 1 Then rez = rez & "eseti"

  If (i = 4 Or i = 10) And cd <> 1 Then
   If cj = 1 Then
    sl1 = "edna"
   ElseIf cj = 2 Then
    sl1 = "dve"
   End If
  End If

  rez = rez & sl1

  Select Case i

   Case 1
    rez = rez & "bilion"
    If cj > 1 Or cd = 1 Then rez = rez & "a"

   Case 4
    rez = rez & "milijard"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Then
     rez = rez & "i"
    ElseIf cj = 1 Then
     rez = rez & "i"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "i"
    ElseIf cj > 1 Then
     rez = rez & "i"
    End If

   Case 7
    rez = rez & "milion"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj <> 1 Then
     rez = rez & "i"
    End If

   Case 10
    rez = rez & "iljad"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 9) Or cj = 1 Then
     rez = rez & "a"
    ElseIf trojka = 1 Then
     rez = rez & "i"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "i"
    ElseIf cj > 1 Then
     rez = rez & "i"
    End If

  End Select
 End If
 i = i + 3
Loop

slovima = rez & "den."

End Function






What doesn't kill me, costs me money!
 
Odgovor na temu

mld

Član broj: 156249
Poruke: 274
*.adsl-2.sezampro.yu.



+13 Profil

icon Re: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?28.09.2009. u 10:41 - pre 176 meseci
Proverite nešto malo brlja sa minusnim brojevima sa decimalama.
Pokušajte broj 111.11 i -111.11 videćete šta se dobija.
I kod drugih brojeva je isto.
Ovo sam proveravao u priloženom Excel fajlu.
 
Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2267
194.106.170.*

Sajt: www.gowi.rs


+109 Profil

icon Re: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?28.09.2009. u 11:48 - pre 176 meseci
Pogledaj malo iznad. Već je objašnjeno da funkcija za negativne brojeve ne radi i kako to možeš da prevaziđeš.

Nije to loše Rembrante, samo što ne bi dodao još malo boje?
 
Odgovor na temu

drnesha
Ruma

Član broj: 11146
Poruke: 3
93.86.30.*

ICQ: 2765023
Sajt: drnesha.tripod.com


Profil

icon Re: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?30.09.2009. u 08:39 - pre 176 meseci
evo i verzije upotrebljive za fakture - iznos se ispisuje kao
"dvehiljade din i pet para", uz izbegavanje ispisa "nula para"
Code:

Function slovima(broj)

If broj = 0 Then rez = "nula"

ReDim imebr(9)
imebr(1) = "jedan"
imebr(2) = "dva"
imebr(3) = "tri"
imebr(4) = ChrW(269) & "etiri"
imebr(5) = "pet"
imebr(6) = "šest"
imebr(7) = "sedam"
imebr(8) = "osam"
imebr(9) = "devet"

rez = ""
celi = Int(broj)
dec = ((broj - celi) * 100) Mod 100
cbr = Str(celi)
duzina = 16 - Len(cbr)
cBroj = String(duzina, "0") & Right(cbr, Len(cbr) - 1)

i = 1

Do While i < 15
 tric = Mid(cBroj, i, 3)
 trojka = Val(tric)
 If tric <> "000" Then
  cs = Val(Mid(tric, 1, 1))
  cd = Val(Mid(tric, 2, 1))
  cj = Val(Mid(tric, 3, 1))
  Select Case cs
   Case 2
    rez = rez & "dve"
   Case Is > 2
    rez = rez & imebr(cs)
  End Select

  Select Case cs
   Case 1
    rez = rez & "stotinu"
   Case 2, 3, 4
    rez = rez & "stotine"
   Case Is > 4
    rez = rez & "stotina"
  End Select

  If cj = 0 Then sl1 = "" Else sl1 = imebr(cj)

  Select Case cd
   Case 4
    rez = rez & ChrW(269) & "etr"
   Case 6
    rez = rez & "šez"
   Case 5
    rez = rez & "pe"
   Case 9
    rez = rez & "deve"
   Case 2, 3, 7, 8
    rez = rez & imebr(cd)
   Case 1
    sl1 = ""
    Select Case cj
     Case 0
      rez = rez & "deset"
     Case 1
      rez = rez & "jeda"
     Case 4
      rez = rez & ChrW(269) & "etr"
     Case Else
      rez = rez & imebr(cj)
    End Select
   If cj > 0 Then rez = rez & "naest"
  End Select

  If cd > 1 Then rez = rez & "deset"

  If (i = 4 Or i = 10) And cd <> 1 Then
   If cj = 1 Then
    sl1 = "jedna"
   ElseIf cj = 2 Then
    sl1 = "dve"
   End If
  End If

  rez = rez & sl1

  Select Case i

   Case 1
    rez = rez & "bilion"
    If cj > 1 Or cd = 1 Then rez = rez & "a"

   Case 4
    rez = rez & "milijard"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Then
     rez = rez & "i"
    ElseIf cj = 1 Then
     rez = rez & "a"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "i"
    ElseIf cj > 1 Then
     rez = rez & "e"
    End If

   Case 7
    rez = rez & "milion"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj <> 1 Then
     rez = rez & "a"
    End If

   Case 10
    rez = rez & "hiljad"
    If ((trojka Mod 100) > 11 And (trojka Mod 100) < 19) Or cj = 1 Then
     rez = rez & "a"
    ElseIf trojka = 1 Then
     rez = rez & "u"
    ElseIf cj > 4 Or cj = 0 Then
     rez = rez & "a"
    ElseIf cj > 1 Then
     rez = rez & "e"
    End If

  End Select
 End If
 i = i + 3
Loop

slovima = rez & " din " & slovimapare(dec)

End Function

Function slovimapare(broj) As String
' konvertuje broj do 99 u tekst
 
 Dim cBroj As String
 ReDim imebr(9)
 imebr(1) = "jedan"
 imebr(2) = "dva"
 imebr(3) = "tri"
 imebr(4) = ChrW(269) & "etiri"
 imebr(5) = "pet"
 imebr(6) = "šest"
 imebr(7) = "sedam"
 imebr(8) = "osam"
 imebr(9) = "devet"
 
 cBroj = Format(broj, "00")
 
 cd = Val(Mid(cBroj, 1, 1))
 cj = Val(Mid(cBroj, 2, 1))
 
 If broj = 0 Then
    slovimapare = ""
    GoTo Kraj
 End If
 
 If cj = 0 Then sl1 = "" Else sl1 = imebr(cj)
 
 Select Case cd
   Case 4
    rez = rez & ChrW(269) & "etr"
   Case 6
    rez = rez & "šez"
   Case 5
    rez = rez & "pe"
   Case 9
    rez = rez & "deve"
   Case 2, 3, 7, 8
    rez = rez & imebr(cd)
   Case 1
    sl1 = ""
    Select Case cj
     Case 0
      rez = rez & "deset"
     Case 1
      rez = rez & "jeda"
     Case 4
      rez = rez & ChrW(269) & "etr"
     Case Else
      rez = rez & imebr(cj)
    End Select
   If cj > 0 Then rez = rez & "naest"
  End Select

  If cd > 1 Then rez = rez & "deset"

  If cd <> 1 Then
   If cj = 1 Then
    sl1 = "jedna"
   ElseIf cj = 2 Then
    sl1 = "dve"
   End If
  End If

  rez = rez & sl1 & " par"
  
  If cj >= 2 And cj <= 4 And cd <> 1 Then
    rez = rez & "e"
  Else
    rez = rez & "a"
  End If
  slovimapare = " i " & rez


Kraj:
End Function


od PRC-a glava ne boli
majstora je mnogo, jedan je drnesha & sinovi
P.S. PRC je Profesionalni Racunarski Centar
 
Odgovor na temu

[es] :: Office :: Excel :: [Excel] Promjena makroa za ispisivanje brojeva slovima. How?

Strane: 1 2 3

[ Pregleda: 27391 | Odgovora: 40 ] > FB > Twit

Postavi temu Odgovori

Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.