Sayıyı Yazıya Çevirme
Bu konuda sayısız örnek mevcut aslında.
Bunlardan birini daha kısa ve kod tekniğinin anlaşılması açısından aşağıda ekledim.
Bundan başka uzun kuruşlu ifadelerde yuvarlama hataları çıkabiliyor. Aşağıda özel yuvarlama fonksiyonu "RoundA" bulunuyor.
Kod:
Function YTL(Para) As String
Dim tum$, tam$, kurus$, YTL_birim$, krs_birim$
tum = RoundA(Replace(Para, "-", ""), 2)
tam = Fix(tum)
kurus = RoundA(tum - tam, 2) * 100
YTL_birim = IIf(tam = 0, "", " YTL ")
krs_birim = IIf(kurus = 0, "", " YKR")
YTL = Ceviri(tam) & YTL_birim & Ceviri(kurus) & krs_birim
End Function
Private Function Ceviri(Say As String) As String
Dim arr() As Variant, c(1 To 3) As String, tmp As String, s As Byte
arr = Array("", "BİR", "İKİ", "ÜÇ", "DÖRT", "BEŞ", "ALTI", "YEDİ", "SEKİZ", "DOKUZ", _
"", "ON", "YİRMİ", "OTUZ", "KIRK", "ELLİ", "ALTMIŞ", "YETMİŞ", "SEKSEN", "DOKSAN", _
"", "YÜZ", "İKİYÜZ", "ÜÇYÜZ", "DÖRTYÜZ", "BEŞYÜZ", "ALTIYÜZ", "YEDİYÜZ", "SEKİZYÜZ", "DOKUZYÜZ", _
"TRİLYON", "MİLYAR", "MİLYON", "BİN", "")
Say = String$(15 - Len(Say), "0") + Say
For i = 1 To 15 Step 3
s = s + 1
c(1) = Mid$(Say, i, 1)
c(2) = Mid$(Say, i + 1, 1)
c(3) = Mid$(Say, i + 2, 1)
tmp = arr(20 + c(1)) & arr(10 + c(2)) & arr(c(3))
If tmp <> "" Then tmp = IIf(s = 4 And Trim$(tmp) = "BİR", "BİN", tmp & arr(30 + (s - 1)))
Ceviri = Ceviri & tmp
Next
Erase arr
Erase c
tmp = Empty
End Function
Private Function RoundA(Sayi, Optional Basamak As Long)
Kat& = 10 ^ Abs(Basamak)
If Basamak >= 0 Then RoundA = CDbl(FormatNumber(Left(Sayi, 30), Basamak))
If Basamak < 0 Then RoundA = CDbl(RoundA(FormatNumber(Left(Sayi, 30) / Kat), 0) * Kat)
End Function