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
Převod čísla na text v OpenOffice a MS Excel
Moderátor: Moderátoři Živě.cz
'---------------------------------------------------------------------------------------
' 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
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?
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
Uživatelé procházející toto fórum: Žádní registrovaní uživatelé a 0 návštevníků