Přidat otázku mezi oblíbenéZasílat nové odpovědi e-mailemVyřešeno Excel číslo slovy

Dobrý den,
můžete mě, prosím poradit z makrem.

píše to např.: do buňky A1 zadám 302 a napíše to slovy: třistadvě
Potřebuji
za 1. buňka A1 dám 302 a aby to napsalo Třista dvě
za 2. buňka A1 dám 302 a aby to napsalo Třista dvě eura

Makro:
Function epfCISLOSLOVNE(Cislo As Double, Optional Velke As Boolean = True) As _
String

Dim aJednotky
Dim aDesitky
Dim aStovky
Dim aRady
Dim aRady1
Dim aRady234

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 strDesitkyJednotky As String
Dim strCisloText As String

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

'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(Cislo))
'délka čísla po zaokrouhlení na trojice nahoru
iDelka3 = WorksheetFunction.Ceiling(iDelka, 3)
'číslo formátované do trojic
strCislo3 = Format(Cislo, String(iDelka3, "0"))
'počet trojic
iPocet3 = iDelka3 \ 3

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

'reset proměnných
strStovky = ""
strDesitkyJednotky = ""
strRady = ""

'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
If iStovky = 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 Then
If iPocet3 = 1 Then
strDesitkyJednotky = "nula"
End If
Else
'text tisíců, milionů, ...
strRady = aRady(iPocet3 - i + 1)
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, miliardy)
If (iStovky = 0 And iPocet3 = 1) Or (iStovky = 0 And iPocet3 = _
4) 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(Velke, UCase(Left$(strCisloText, 1)) & _
Mid$(strCisloText, 2), strCisloText)

End Function

Moc Děkuji

Jsou zobrazeny jen nové odpovědi. Zobrazit všechny
Předmět Autor Datum
Ty si fakt taký nemožný, že si to nevieš upraviť podľa seba? 'pole pro stovky aStovky = Array("", "s…
pme 26.08.2016 20:26
pme
Je možné, aby to na konci částky psalo Eur. Děkuji za pomoc.
Etkin 27.08.2016 19:54
Etkin
epfCISLOSLOVNE = IIf(Velke, UCase(Left$(strCisloText, 1)) & _ Mid$(strCisloText, 2), strCisloText) &…
Siki83 28.08.2016 01:15
Siki83
Mohlo by to prosím ještě skloňovat Jedno Euro , Dvě Eura ..... Moc díki
Etkin 28.08.2016 15:53
Etkin
Toto je ale poradňa - od slova poradiť, nie "urobte to za mňa" !!! Trochu si si to tu pomýlil.]:(
pme 28.08.2016 17:02
pme
Zkoušel jsem to, ale nevím jak nemohu na to dojít. Tak moc prosím děkuji
Etkin 28.08.2016 17:15
Etkin
Čo si skúšal? Há? Nič... Zatiaľ tu len prosíš...ešte som Ťa nevidel prejaviť vlastnú iniciatívu.
pme 28.08.2016 17:19
pme
If Koruny = 1 Then Select Case dblCislo Case 1 ktmp = "Eur" Case 2, 3, 4 ktmp = "Euro" Case Else ktm…
Etkin 28.08.2016 19:27
Etkin
1 Eur, 2 Euro, 5 Eura? Asi ne.
Wikan 28.08.2016 19:37
Wikan
A můžeš mi, prosím napsat jak to má byt. Nevím ani kam to správně vložit. Dělám to od rána a nic nef…
Etkin 28.08.2016 20:27
Etkin
Function epfCISLOSLOVNE(Cislo As Double, Optional Velke As Boolean = True) As _ String Dim aJednotky…
Siki83 28.08.2016 21:52
Siki83
Děkuji Pokud bych mohl poslat financní dar tak jak. Excelu moc nerozumím a už vůbec ne makru ale Mů… poslední
Etkin 28.08.2016 22:13
Etkin

Ty si fakt taký nemožný, že si to nevieš upraviť podľa seba?
'pole pro stovky
aStovky = Array("", "sto", "dvěstě", "třista", "čtyřista", "pětset", _
"šestset", "sedmset", "osmset", "devětset")

Ak to chceš veľkým písmom, potom si to zmeň z "třista" na "Třista"... ak tam chceš ešte medzeru, potom "Třista "...

Function epfCISLOSLOVNE(Cislo As Double, Optional Velke As Boolean = True) As _
    String

    Dim aJednotky
    Dim aDesitky
    Dim aStovky
    Dim aRady
    Dim aRady1
    Dim aRady234

    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 strDesitkyJednotky As String
    Dim strCisloText As String
    
    Dim mena As String

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

    '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(Cislo))
    'délka čísla po zaokrouhlení na trojice nahoru
    iDelka3 = WorksheetFunction.Ceiling(iDelka, 3)
    'číslo formátované do trojic
    strCislo3 = Format(Cislo, String(iDelka3, "0"))
    'počet trojic
    iPocet3 = iDelka3 \ 3

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

        'reset proměnných
        strStovky = ""
        strDesitkyJednotky = ""
        strRady = ""

        '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
        If iStovky = 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 Then
                    If iPocet3 = 1 Then
                        strDesitkyJednotky = "nula"
                    End If
                Else
                    'text tisíců, milionů, ...
                    strRady = aRady(iPocet3 - i + 1)
                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, miliardy)
                If (iStovky = 0 And iPocet3 = 1) Or (iStovky = 0 And iPocet3 = _
                    4) 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

                Select Case Cislo
                    Case 2 To 4
                        mena = " Eura"
                    Case Else
                        mena = " Euro"
                End Select




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

End Function

Zpět do poradny Odpovědět na původní otázku Nahoru