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
↧