Excel- Převod čísla na slovní vyjádření

Programy pro práci s textem, tabulkami, prezentacemi

Moderátor: Moderátoři Živě.cz

Odeslat příspěvekod d4d1k 18. 6. 2008 12:32

Ahojky, řeším jeden problém v excelu a sice jestli umí převést číslo na slovní vyjádření.
Potřeboval bych, aby k číslu zapsanému v jedné buňce jako číslo se automaticky vytvářelo jeho slovní vyjádření ve druhé buňce.

Příklad: A1= 253
B1= dvěstěpadesáttři

Pokud změním číslo v buňce A1, změní se i slovní vyjádření příslušného čísla v buňce B1.

Existuje na to v Excelu nějaká funkce? Já jsem na to bohužel nepřišel.
Pokud mi někdo poradíte, budu velmi vděčný.

Díky moc
d4d1k
Kolemjdoucí

Odeslat příspěvekod Marek Lutonský 18. 6. 2008 12:50

Funkce na tohle neexistuje. Vzhledem k tomu, že čeština skloňuje a v různých případech mají číslovky různé tvary, bylo by asi docela komplikované něco takového vytvořit. Určitě by to ale šlo.

Resp. v jakém rozsahu se ta čísla pohybují? Jaké je nejmenší a největší možné? Jestli jich není moc, tak by se jednoduše v druhém listu ke každému číslu napsalo jeho slovní vyjádření a funkcí Svyhledat by se k číselnému vyjádření hledalo příslušné slovo.
Marek Lutonský
Hlavní administrátor
Uživatelský avatar

Odeslat příspěvekod obcasny_navstevnik 18. 6. 2008 16:52

funkce ve VBA pro prevod na slovni vyjadreni, vlozit do modulu, pak ve vlastnich funkcich.

pripadne uprav - odstran mezery (forum nejak v retezcich mrsi diakritiku):

Function Slovy(Cis As Double) As String
Dim StrCis As String
Dim LenCis As Byte, Rad As Integer, Ofs As Byte
Dim Pol As Byte, pom As String, pom1 As String, pom2 As String
Dim Jedn As Variant, Des1 As Variant, Des As Variant, Sta As Variant
Dim JednTM As Variant, Tis As Variant, Mil As Variant
'
If IsEmpty(Cis) Then End
'
Jedn = Array("", "jedna", "dvì", "tøi", "ètyøi", _
"pìt", "šest", "sedm", "osm", "devìt")
Des1 = Array("deset", "jedenáct", "dvanáct", "tøináct", "ètrnáct", _
"patnáct", "šestnáct", "sedmnáct", "osmnáct", "devatenáct")
Des = Array("", "", "dvacet ", "tøicet ", "ètyøicet ", "padesát ", _
"šedesát ", "sedmdesát ", "osmdesát ", "devadesát ")
Sta = Array("", "jedno sto ", "dva sta ", "tøi sta ", "ètyøi sta ", _
"pìt set ", "šest set ", "sedm set ", "osm set ", "devìt set ")
Tis = Array("tisíc ", "tisíc ", "tisíce ", "tisíce ", "tisíce ", _
"tisíc ", "tisíc ", "tisíc ", "tisíc ", "tisíc ")
JednTM = Array("", "jeden ", "dva ", "tøi ", "ètyøi ", _
"pìt ", "šest ", "sedm ", "osm ", "devìt ")
Mil = Array("milionù ", "milion ", "miliony ", "miliony ", "miliony ", _
"milionù ", "milionù ", "milionù ", "milionù ", "milionù ")
'
'
StrCis = CStr(Format(Cis, "0.00"))
Pol = InStr(StrCis, ",") - 1 ' poloha radu jednotek v cisle
If Pol > 9 Then Slovy = ">999 999 999": Exit Function
Rad = 0 ' rad cislice v cisle
Slovy = ""
Do
pom = Mid(StrCis, Pol, 1)
If Pol > 1 Then
pom1 = Mid(StrCis, Pol - 1, 1)
Else
pom1 = "0"
End If
'
Select Case Rad
Case 0
pom2 = IIf(pom1 <> 1, Jedn(pom), Des1(pom)): Ofs = IIf(pom1 <> 1, 1, 2)
Case 1
pom2 = Des(pom): Ofs = 1
Case 2
pom2 = Sta(pom): Ofs = 1
Case 3
pom2 = IIf(pom1 <> 1, JednTM(pom), Des1(pom)): Ofs = IIf(pom1 <> 1, 1, 2)
If Pol > 3 Then ' kdyz zustavaji jeste >3 cislice
If Mid(StrCis, Pol - 2, 3) <> "000" Then
pom2 = pom2 & IIf(pom1 <> 1, Tis(pom), " tisíc ") ' a jsou i tisice -> vlozeni slova tisic
Else
Ofs = 3 ' preskoci na rad 6 - miliony
End If
Else ' kdyz zustava jeste <3 cislice -> vlozeni slova tisic
pom2 = pom2 & IIf(pom1 <> 1, Tis(pom), " tisíc ")
End If
Case 4
pom2 = Des(pom): Ofs = 1
Case 5
pom2 = Sta(pom): Ofs = 1
Case 6
pom2 = IIf(pom1 <> 1, JednTM(pom) & Mil(pom), Des1(pom) & " milionù "): Ofs = IIf(pom1 <> 1, 1, 2)
Case 7
pom2 = Des(pom): Ofs = 1
Case 8
pom2 = Sta(pom): Ofs = 1
End Select
'
Slovy = pom2 & Slovy
Pol = Pol - Ofs: Rad = Rad + Ofs
'
Loop While Pol > 0
Slovy = Trim(Slovy) ' & " " & Right(StrCis, 2) ' pridani destinne casti
End Function
obcasny_navstevnik
Junior

Odeslat příspěvekod d4d1k 18. 6. 2008 23:18

Děkuji moc za pomoc, tohle je přesně to co jsem potřeboval!
Odstranil jsem mezery, opravil diakritiku a teď to šlape jako hodinky (o:

Kdyby to někdo někdy ještě potřeboval, házím upravený kód:

V Excelu na Kartu Vývojář > Visual Basic > Insert > Module (do okna pak vložit text níže)
Funkci vyvoláte přes vlastní funkce nebo zápisem: =slovy(odkaz na buňku s číslem nebo číslo)

Kód: Vybrat vše
Function Slovy(Cis As Double) As String
Dim StrCis As String
Dim LenCis As Byte, Rad As Integer, Ofs As Byte
Dim Pol As Byte, pom As String, pom1 As String, pom2 As String
Dim Jedn As Variant, Des1 As Variant, Des As Variant, Sta As Variant
Dim JednTM As Variant, Tis As Variant, Mil As Variant
'
If IsEmpty(Cis) Then End
'
Jedn = Array("", "jedna", "dvě", "tři", "čtyři", _
"pět", "šest", "sedm", "osm", "devět")
Des1 = Array("deset", "jedenáct", "dvanáct", "třináct", "čtrnáct", _
"patnáct", "šestnáct", "sedmnáct", "osmnáct", "devatenáct")
Des = Array("", "", "dvacet", "třicet", "čtyřicet", "padesát", _
"šedesát", "sedmdesát", "osmdesát", "devadesát")
Sta = Array("", "jednosto", "dvěsta", "třista", "čtyřista", _
"pětset", "šestset", "sedmset", "osmset", "devětset")
Tis = Array("tisíc", "tisíc", "tisíce", "tisíce", "tisíce", _
"tisíc", "tisíc", "tisíc", "tisíc", "tisíc")
JednTM = Array("", "jeden", "dva", "tři", "čtyři", _
"pět", "šest", "sedm", "osm", "devět")
Mil = Array("milionů", "milion", "miliony", "miliony", "miliony", _
"milionů", "milionů", "milionů", "milionů", "milionů")
'
'
StrCis = CStr(Format(Cis, "0.00"))
Pol = InStr(StrCis, ",") - 1 ' poloha radu jednotek v cisle
If Pol > 9 Then Slovy = ">999 999 999": Exit Function
Rad = 0 ' rad cislice v cisle
Slovy = ""
Do
pom = Mid(StrCis, Pol, 1)
If Pol > 1 Then
pom1 = Mid(StrCis, Pol - 1, 1)
Else
pom1 = "0"
End If
'
Select Case Rad
Case 0
pom2 = IIf(pom1 <> 1, Jedn(pom), Des1(pom)): Ofs = IIf(pom1 <> 1, 1, 2)
Case 1
pom2 = Des(pom): Ofs = 1
Case 2
pom2 = Sta(pom): Ofs = 1
Case 3
pom2 = IIf(pom1 <> 1, JednTM(pom), Des1(pom)): Ofs = IIf(pom1 <> 1, 1, 2)
If Pol > 3 Then ' kdyz zustavaji jeste >3 cislice
If Mid(StrCis, Pol - 2, 3) <> "000" Then
pom2 = pom2 & IIf(pom1 <> 1, Tis(pom), " tisíc ") ' a jsou i tisice -> vlozeni slova tisic
Else
Ofs = 3 ' preskoci na rad 6 - miliony
End If
Else ' kdyz zustava jeste <3 cislice -> vlozeni slova tisic
pom2 = pom2 & IIf(pom1 <> 1, Tis(pom), " tisíc ")
End If
Case 4
pom2 = Des(pom): Ofs = 1
Case 5
pom2 = Sta(pom): Ofs = 1
Case 6
pom2 = IIf(pom1 <> 1, JednTM(pom) & Mil(pom), Des1(pom) & " milionu` "): Ofs = IIf(pom1 <> 1, 1, 2)
Case 7
pom2 = Des(pom): Ofs = 1
Case 8
pom2 = Sta(pom): Ofs = 1
End Select
'
Slovy = pom2 & Slovy
Pol = Pol - Ofs: Rad = Rad + Ofs
'
Loop While Pol > 0
Slovy = Trim(Slovy) ' & " " & Right(StrCis, 2) ' pridani destinne casti
End Function


Velké díky obcasny_navstevniku ;-)
d4d1k
Kolemjdoucí

Odeslat příspěvekod vlkousek 8. 7. 2008 13:06

Velké díky oběma. Mám kacířskou otázku, dalo by se něco takového provést i ve Wordu?
vlkousek
Junior
Uživatelský avatar

Odeslat příspěvekod obcasny_navstevnik 8. 7. 2008 14:22

nic tomu nebrani, jen tak prvotni navrh a zjednodusene:

Do dokumentu vlozit z ovladacich prvku TextBox.
Vyse uvedenou funkci vlozit v editoru VBA do modulu s upravami:

Function Slovy(Cis As Variant) As String
...
radek:
If IsEmpty(Cis) Then End
nahradit:

If Not IsNumeric(Cis) Then Slovy = "Err": Exit Function

Do objektu MS Word ThisDocument vlozit udalostni proceduru, napr. pro dvojklik na Textbox po vlozeni cisla:
Kód: Vybrat vše
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Selection.EndKey Unit:=wdLine
Selection.TypeText Text:=vbTab & Slovy(TextBox1.Value)
End Sub


a upravit ji do pozadovane podoby.
obcasny_navstevnik
Junior

Odeslat příspěvekod vlkousek 11. 7. 2008 20:07

Díky moc. Jsi fakt machr, Občasný návštěvníku.
vlkousek
Junior
Uživatelský avatar

Odeslat příspěvekod neveceral 14. 9. 2008 19:00

jsem amatér, umím si pouze nahrát makro :potichu , nešlo by vysvětlit i pro mě, jak na to? Nešlo by to upravit, že by se označilo číslo a přes "nějaké" tlačítko se číslo převedlo na text? Díky.
neveceral
Junior
Uživatelský avatar

Odeslat příspěvekod obcasny_navstevnik 15. 9. 2008 09:48

do dokumentu v editoru VBA vloz do modulu nasledujici:

Kód: Vybrat vše
Option Explicit

Sub Prevod()
Dim txt As String

txt = Selection.Text
If IsNumeric(txt) Then MsgBox Slovy1(txt)
End Sub

Function Slovy1(Cis) As String
Dim StrCis As String
Dim LenCis As Byte, Rad As Integer, Ofs As Byte
Dim Pol As Byte, pom As String, pom1 As String, pom2 As String
Dim Jedn As Variant, Des1 As Variant, Des As Variant, Sta As Variant
Dim JednTM As Variant, Tis As Variant, Mil As Variant
'
  If Not IsNumeric(Cis) Then Slovy1 = "Hodnota není číslo!": Exit Function
  If Cis > 999999999 Then Slovy1 = "Hodnota>999 999 999!": Exit Function
'
  Jedn = Array("", "jedna", "dvě", "tři", "čtyři", _
    "pět", "šest", "sedm", "osm", "devět")
  Des1 = Array("deset", "jedenáct", "dvanáct", "třináct", "čtrnáct", _
    "patnáct", "šestnáct", "sedmnáct", "osmnáct", "devatenáct")
  Des = Array("", "", "dvacet", "třicet", "čtyřicet", "padesát", _
    "šedesát", "sedmdesát", "osmdesát", "devadesát")
  Sta = Array("", "jednosto", "dvasta", "třista", "čtyřista", _
    "pětset", "šestset", "sedmset", "osmset", "devětset")
  Tis = Array("tisíc", "tisíc", "tisíce", "tisíce", "tisíce", _
    "tisíc", "tisíc", "tisíc", "tisíc", "tisíc")
  JednTM = Array("", "jeden", "dva", "tři", "čtyři", _
    "pět", "šest", "sedm", "osm", "devět")
  Mil = Array("milionů", "milion", "miliony", "miliony", "miliony", _
  "milionů", "milionů", "milionů", "milionů", "milionů")
'
'
  StrCis = CStr(Format(Cis, "0.00"))
  Pol = InStr(StrCis, ",") - 1 ' poloha radu jednotek v cisle
  Rad = 0 ' rad cislice v cisle
  Slovy1 = ""
  Do
    pom = Mid(StrCis, Pol, 1)
    If Pol > 1 Then
      pom1 = Mid(StrCis, Pol - 1, 1)
    Else
      pom1 = "0"
    End If
'
    Select Case Rad
      Case 0
        pom2 = IIf(pom1 <> 1, Jedn(pom), Des1(pom)): Ofs = IIf(pom1 <> 1, 1, 2)
      Case 1
        pom2 = Des(pom): Ofs = 1
      Case 2
        pom2 = Sta(pom): Ofs = 1
      Case 3
        pom2 = IIf(pom1 <> 1, JednTM(pom), Des1(pom)): Ofs = IIf(pom1 <> 1, 1, 2)
        If Pol > 3 Then ' kdyz zustavaji jeste >3 cislice
          If Mid(StrCis, Pol - 2, 3) <> "000" Then
            pom2 = pom2 & IIf(pom1 <> 1, Tis(pom), "tisíc") ' a jsou i tisice -> vlozeni slova tisic
          Else
            Ofs = 3 ' preskoci na rad 6 - miliony
          End If
        Else ' kdyz zustava jeste <3 cislice -> vlozeni slova tisic
          pom2 = pom2 & IIf(pom1 <> 1, Tis(pom), "tisíc")
        End If
      Case 4
        pom2 = Des(pom): Ofs = 1
      Case 5
        pom2 = Sta(pom): Ofs = 1
      Case 6
        pom2 = IIf(pom1 <> 1, JednTM(pom) & Mil(pom), Des1(pom) & "milionů"): Ofs = IIf(pom1 <> 1, 1, 2)
      Case 7
        pom2 = Des(pom): Ofs = 1
      Case 8
        pom2 = Sta(pom): Ofs = 1
    End Select
'
    Slovy1 = pom2 & Slovy1
    Pol = Pol - Ofs: Rad = Rad + Ofs
'
  Loop While Pol > 0
  Slovy1 = Trim(Slovy1) ' & " " & Right(StrCis, 2) ' pridani destinne casti
End Function


subrutine Prevod (uprav si dle potreby) prirad klavesovou zkratku (postup v napovede)
vyber cislo, stiskni klavesovou zkratku
obcasny_navstevnik
Junior

Odeslat příspěvekod neveceral 15. 9. 2008 19:39

super, děkuji, má to ale malou chybku, číslo slovy se nenapíše do dokumentu, ale pouze se rozbrazí ve zprávě
http://img225.imageshack.us/my.php?image=beznzvuxi6.jpg
neveceral
Junior
Uživatelský avatar

Odeslat příspěvekod obcasny_navstevnik 15. 9. 2008 21:01

to je tak velky problem upravit subrutinu?

Kód: Vybrat vše
Sub Prevod()
Dim txt As String
  txt = Selection.Text
  If IsNumeric(txt) Then
    'MsgBox Slovy1(txt)
    Selection.MoveRight
    Selection.TypeText "  " & Slovy1(txt)
  End If
End Sub
obcasny_navstevnik
Junior

Odeslat příspěvekod neveceral 15. 9. 2008 21:19

velmi děkuji, bohužel, problém to pro mě je, protože jsem sotva pochopil, že problém je msgbox, mé schopnosti končí v nahrání makra, max. v jeho lehké úpravě. Ještě jednou velmi děkuji.
neveceral
Junior
Uživatelský avatar

Odeslat příspěvekod jambo1109 31. 1. 2009 22:21

Díky moc za pomoc, funguje i v Accessu, ušetří mi to spoustu práce.
Hezký den. ;-)
jambo1109
Kolemjdoucí

Odeslat příspěvekod ByTrit 26. 4. 2009 19:51

Zdravim mam mensi problem pri vacsich cislach (ako su miliony) sa pokazi sklonovanie cisloviek (napr z cisla 22milionov to spravi 22miliony co je blbost)
vo VBA som kedysi robil ale to je davno (asi 5 rokov dozadu) nasiel by sa niekto kto by vedel opravit toto sklonovanie?
ByTrit
Kolemjdoucí

Odeslat příspěvekod fatman 26. 4. 2009 20:14

OT:
ByTrit píše:napr z cisla 22milionov to spravi 22miliony co je blbost


Nevím jak ve slovenštině, ale v češtině je to správně - 22 miliony, 21 kilogram (čteno dvacet jeden kilogram - říkáme přeci jeden kilogram a ne jedna kilogramů), nicméně je povolen i tvar dvacetjedna kilogramů a korektní tvar 21 kilogram začíná být chápan jako zastaralý.
"Věřím v reinkarnaci, jakožto nutnou likvidaci materialisace lidské idealisace, bez vyloučení sensace!"
(J. Váchal, Krvavý román)
fatman
Junior
Uživatelský avatar

Další stránka

Kdo je online

Uživatelé procházející toto fórum: Žádní registrovaní uživatelé a 0 návštevníků