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 AI Wintermute 18. 6. 2012 09:10

asi je to passé, ale třeba to pomůže někomu dalšímu - zkuste tuhle stránku - je tam ke stažení verze jako pro OpenOffice/LibreOffice, tak pro Excel 8-D

Převod čísla na text v OpenOffice a MS Excel
AI Wintermute
Junior
Uživatelský avatar

Odeslat příspěvekod xlnc 25. 6. 2012 12:49

Algoritmy jsou víceméně podobné, přidávám svou verzi do placu.

Kód: Vybrat vše
'---------------------------------------------------------------------------------------
' Procedura : epfCISLOSLOVNE
' Autor     : Petr Pecháček, Excelplus.NET
' Datum     : 7.11.2011
' Popis     : Funkce vrátí číslo vyjádřené slovně v poštovním formátu
' Příklad   : strCisloSlovne = epfCISLOSLOVNE(1567129)
'---------------------------------------------------------------------------------------
'
Public Function epfCISLOSLOVNE(ByVal Castka As Double, Optional ByVal _
    VelkePrvniPismeno As Boolean = True) As String

    Dim aJednotky As Variant
    Dim aDesitky As Variant
    Dim aStovky As Variant
    Dim aRady As Variant
    Dim aRady1 As Variant
    Dim aRady234 As Variant

    Dim i As Integer
    Dim iPocet3 As Integer
    Dim iDelka As Integer
    Dim iDelka3 As Integer
    Dim iStovky As Integer
    Dim iDesitkyJednotky As Integer

    Dim strCislo3 As String
    Dim strStovky As String
    Dim strRady As String
    Dim strDesitkyJednotky As String
    Dim strCisloText As String

    'vynucený přepočet funkce při změně na listu
    Application.Volatile True

    'pole pro desítky
    aDesitky = Array("", "deset", "dvacet", "třicet", "čtyřicet", _
        "padesát", "šedesát", "sedmdesát", "osmdesát", "devadesát")

    'pole pro jednotky
    aJednotky = Array("", "jedna", "dva", "tři", "čtyři", "pět", _
        "šest", "sedm", "osm", "devět", "deset", "jedenáct", "dvanáct", _
        "třináct", "čtrnáct", "patnáct", "šestnáct", "sedmnáct", _
        "osmnáct", "devatenáct")

    'pole pro stovky
    aStovky = Array("", "sto", "dvěstě", "třista", "čtyřista", _
        "pětset", "šestset", "sedmset", "osmset", "devětset")

    'pole pro řády
    aRady = Array("", "tisíc", "milionů", "miliard")
    aRady1 = Array("", "tisíc", "milion", "miliarda")
    aRady234 = Array("", "tisíce", "miliony", "miliardy")

    'skutečná délka čísla
    iDelka = Len(CStr(Castka))
    'délka čísla po zaokrouhlení na trojice nahoru
    iDelka3 = WorksheetFunction.Ceiling(iDelka, 3)
    'číslo formátované do trojic
    strCislo3 = Format(Castka, String(iDelka3, "0"))
    'počet trojic
    iPocet3 = iDelka3 \ 3

    'pro všechny trojice
    For i = 1 To iPocet3

        'počet stovek
        iStovky = Val(Mid(strCislo3, 3 * i - 2, 1))
        'počet desítek a jednotek
        iDesitkyJednotky = Val(Mid(strCislo3, 3 * i - 1, 2))

        'a) bez ošetření "jednosto"
        'strStovky = aStovky(iStovky + 1)

        'b) s ošetřením "jednosto"
        If iStovky = 1 And i = 1 Then
            strStovky = "jedno" & aStovky(iStovky + 1)
        Else
            strStovky = aStovky(iStovky + 1)
        End If

        'rozlišení desítek a jednotek
        Select Case iDesitkyJednotky
            Case 0
                If iStovky = 0 And iPocet3 = 1 Then
                    strDesitkyJednotky = "nula"
                End If
            Case 1
                'výjimka, "jeden" namísto "jedna" z pole
                'pro "jedentisíc", "jedenmilion", ...
                If iStovky = 0 And iPocet3 > 1 And i <> iPocet3 Then
                    'text desítek a jednotek
                    strDesitkyJednotky = "jeden"
                Else
                    'text desítek a jednotek
                    strDesitkyJednotky = aJednotky(iDesitkyJednotky + _
                        1)
                End If
                'text tisíců, milionů, ...
                strRady = aRady1(iPocet3 - i + 1)
            Case 2
                'výjimka, "dvě" namísto "dva" z pole
                'pro "dvě" (koruny)
                If iStovky = 0 And iPocet3 = 1 Then
                    'text desítek a jednotek
                    strDesitkyJednotky = "dvě"
                Else
                    'text desítek a jednotek
                    strDesitkyJednotky = aJednotky(iDesitkyJednotky + _
                        1)
                End If
                'text tisíců, milionů, ...
                strRady = aRady234(iPocet3 - i + 1)
            Case 3, 4
                strDesitkyJednotky = aJednotky(iDesitkyJednotky + 1)
                'text tisíců, milionů, ...
                strRady = aRady234(iPocet3 - i + 1)
            Case 5 To 19
                'text desítek a jednotek
                strDesitkyJednotky = aJednotky(iDesitkyJednotky + 1)
                'text tisíců, milionů, ...
                strRady = aRady(iPocet3 - i + 1)
            Case Is >= 20
                'text desítek a jednotek
                strDesitkyJednotky = aDesitky((iDesitkyJednotky \ 10) _
                    + 1) & aJednotky((iDesitkyJednotky Mod 10) + 1)
                'text tisíců, milionů, ...
                strRady = aRady(iPocet3 - i + 1)
        End Select

        strCisloText = strCisloText & strStovky & strDesitkyJednotky _
            & strRady

    Next i

    epfCISLOSLOVNE = IIf(VelkePrvniPismeno, UCase(Left$(strCisloText, _
        1)) & Mid$(strCisloText, 2), strCisloText)

End Function
Petr Pecháček
xlnc
Junior
Uživatelský avatar

Odeslat příspěvekod mpok 6. 12. 2012 16:43

Ahoj,
je to super a moc díky! :)
Jen mám dotaz ohledně "trvanlivosti".
Zadám si modul do excelu a pak mi převádí čísla na slava, super!
Ale jakmile excel zavřu, tak modul zmizí...
Jde nějak modul "nainstalovat" do excelu natrvalo?
Díky moc za radu! ;-)

Martin
mpok
Kolemjdoucí

Odeslat příspěvekod gabo516 6. 6. 2013 11:56

Dobrý den autorovi i úpravci makra. Mám s ním ale problém. Kód funguje v Excelu 2010. Excel 2002 vypisuje chybu, ale nenašel jsem důvod. Všechny použité fce se zdají být už dříve podporované. Děkuji za pomoc. G
gabo516
Kolemjdoucí

Odeslat příspěvekod JožoS 16. 12. 2014 20:48

ByTrit píše: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?


kód som upravil do sk a aj milióny zobrazuje správne a to som dnes s VBA robil 1.krát

jedine čo sa mi nedarí, aby aj desatinné čísla prepísalo na slovo

Kód: Vybrat vše
Function slovom(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", "dva", "tri", "štyri", _
"päť", "šesť", "sedem", "osem", "deväť")
Des1 = Array("desať", "jedenásť", "dvanásť", "trinásť", "štrnásť", _
"pätnásť", "šestnásť", "sedemnásť", "osmenásť", "devätnásť")
Des = Array("", "", "dvadsať", "tridsať", "štyridsať", "päťdesiat", _
"šesťdesiat", "sedemdesiat", "osemdesiat", "deväťdesiat")
Sta = Array("", "sto", "dvesto", "tristo", "štyristo", _
"päťsto", "šesťsto", "sedemsto", "osemsto", "deväťsto")
Tis = Array("tisíc", "tisíc", "tisíc", "tisíc", "tisíc", _
"tisíc", "tisíc", "tisíc", "tisíc", "tisíc")
JednTM = Array("", "jedna", "dva", "tri", "štyri", _
"päť", "šesť", "sedem", "osem", "deväť")
Mil = Array("miliónov", "milión", "milióny", "milióny", "milióny", _
"miliónov", "miliónov", "miliónov", "miliónov", "miliónov")
'
'
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
'
slovom = pom2 & slovom
Pol = Pol - Ofs: Rad = Rad + Ofs
'
Loop While Pol > 0
slovom = Trim(slovom) ' & " " & Right(StrCis, 2) ' pridani destinne casti
End Function
JožoS
Kolemjdoucí

Odeslat příspěvekod lk123 19. 6. 2017 15:31

Zdravím, chtěl jsem se zeptat, jestli máte někdo zkušenost s touto funkcí v Google disku, nebo Excel on line. Potřeboval bych ji využít v těchto programech.
Děkuji
lk123
Kolemjdoucí

Odeslat příspěvekod LPospa 31. 12. 2017 02:11

Ahoj.

Zrovna jsem vyzkoušel vaše zkušenosti a rady, ale našel jsem drobný problém. Pokud je číslo které se převádí s desetinným koncem, zobrazí se mi slovy pouze hodnota před desetinnou čárkou bez zaokrouhlení, např. 1258,99 napíše jedentisícdvěstěpadesátosm. Potřeboval bych poradit jak to upravit, aby se mi převedla na text až hodnota zaokrouhlená podle matematických pravidel. Pro mě samotného je to španělská vesnice, bez podrobného návodu v češtině či slovenštině bych nerozchodil ani tohle. Tímto taky děkuji všem přispěvatelům, kteří jsou ochotni poradit i takovým lamám, jako jsem já.
LPospa
Kolemjdoucí

Předchozí stránka

Kdo je online

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