Ondalıklı sayıyı metin olarakYTL ve YKR cinsinden yazdÃ

[serbestmali]

Selamlar
2006 yılı itibari ile saymanlıkların Saymanlık işlem ve Ã?deme emirlerinde
kurşlu sisteme geçeceğinden

ondalıklı sayıları YTL ve YKR cinsinden metne çevirme gerekecek
macro yada formülle çözebilirmiyiz


teşekkürler

 

[sero]

bu formulle ytlye çevirebilirsiniz.
Function yaziyacevir(rakam)
'veysel emre tarafından yapılmıştır
Dim grup(5), sayi(10, 3), basamak(5), oku(3)
sayi(0, 1) = "": sayi(0, 2) = "": sayi(0, 3) = ""
sayi(1, 1) = "YÜZ": sayi(1, 2) = "ON": sayi(1, 3) = "BİR"
sayi(2, 1) = "İKİYÜZ": sayi(2, 2) = "YİRMİ": sayi(2, 3) = "İKİ"
sayi(3, 1) = "ÜÇYÜZ": sayi(3, 2) = "OTUZ": sayi(3, 3) = "ÜÇ"
sayi(4, 1) = "DÃ?RTYÜZ": sayi(4, 2) = "KIRK": sayi(4, 3) = "DÃ?RT"
sayi(5, 1) = "BEÞYÜZ": sayi(5, 2) = "ELLİ": sayi(5, 3) = "BEÞ"
sayi(6, 1) = "ALTIYÜZ": sayi(6, 2) = "ALTMIÞ": sayi(6, 3) = "ALTI"
sayi(7, 1) = "YEDİYÜZ": sayi(7, 2) = "YETMİÞ": sayi(7, 3) = "YEDİ"
sayi(8, 1) = "SEKİZYÜZ": sayi(8, 2) = "SEKSEN": sayi(8, 3) = "SEKİZ"
sayi(9, 1) = "DOKUZYÜZ": sayi(9, 2) = "DOKSAN": sayi(9, 3) = "DOKUZ"
basamak(5) = "TRİLYON"
basamak(4) = "MİLYAR"
basamak(3) = "MİLYON"
basamak(2) = "BİN"
basamak(1) = ""
lira = Int(rakam)

kucuk = 1 ' Küçük harflerle yazması için

If kucuk = 1 Then
For x = 0 To 9
For y = 1 To 3
sayi(x, y) = Replace(sayi(x, y), "I", "ı")
sayi(x, y) = Replace(sayi(x, y), "İ", "i")
sayi(x, y) = LCase(sayi(x, y))
Next
Next

For y = 2 To 5
basamak = Replace(basamak, "I", "ı")
basamak = Replace(basamak, "İ", "i")
basamak = LCase(basamak)
Next
End If


kurus = Round(rakam - lira, 2) * 100
If Len(lira) > 15 Then
MsgBox ("Bu fonksiyon en fazla 15 haneli sayılar için çalışır.")
End
End If
kalan = lira
yaziyacevir = ""

For x = 1 To 5
A = 15 - 3 * x
If Len(lira) > A Then
grup(6 - x) = Int(kalan / 10 ^ A)
kalan = kalan - (grup(6 - x) * 10 ^ A)
End If

Next x

If grup(5) > 0 Then
oku(1) = Int(grup(5) / 100)
baskalan = grup(5) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(5)
End If

If grup(4) > 0 Then
oku(1) = Int(grup(4) / 100)
baskalan = grup(4) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(4)
End If

If grup(3) > 0 Then
oku(1) = Int(grup(3) / 100)
baskalan = grup(3) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(3)
End If

If grup(2) = 1 Then
yaziyacevir = yaziyacevir + "BİN"
End If

If grup(2) > 1 Then
oku(1) = Int(grup(2) / 100)
baskalan = grup(2) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(2)
End If

If grup(1) > 0 Then
oku(1) = Int(grup(1) / 100)
baskalan = grup(1) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(1)
End If
yaziyacevir = yaziyacevir + "YTL."
If kurus > 0 Then
oku(2) = 0
If Len(kurus) > 1 Then
oku(2) = Int(kurus / 10)
End If
oku(3) = kurus - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(2), 2) + sayi(oku(3), 3) + "YKR."
End If
End Function

 

[elm]

Ondalıklı sayıları metne çevirmek yeni bir olay değil çünkü 2005 yılı yeni para birimimizle geçti.
Yeni Türk Lirası ve Yeni Kuruş cinsinden rakamları metne çevirmek:

Function Yaziyla(Sayi#)
Dim virgul2 As String
Dim cevap As String
Dim yazi As String
Dim Say As String
Dim uclu As String
Dim virgul As Integer
Dim o As Integer
Dim b As Integer
Dim x As Integer
Dim i As Integer
Dim y As Integer
Dim YTL As String
Dim YKR As String

If Sayi# = 0 Then Yaziyla = "Sıfır": Exit Function

ReDim birler$(10), onlar$(10), basamak$(5)

birler$(0) = "": birler$(1) = "Bir"
birler$(2) = "İki": birler$(3) = "Üç"
birler$(4) = "Dört": birler$(5) = "Beş"
birler$(6) = "Altı": birler$(7) = "Yedi"
birler$(8) = "Sekiz": birler$(9) = "Dokuz"

onlar$(0) = "": onlar$(1) = "On"
onlar$(2) = "Yirmi": onlar$(3) = "Otuz"
onlar$(4) = "Kırk": onlar$(5) = "Elli"
onlar$(6) = "Altmış": onlar$(7) = "Yetmiş"
onlar$(8) = "Seksen": onlar$(9) = "Doksan"

basamak$(1) = "": basamak$(2) = "Bin "
basamak$(3) = "Milyon ": basamak$(4) = "Milyar "
basamak$(5) = "Trilyon "

virgul2 = ""
cevap = ""

'AÞAÐIDAKİ 2 SATIRDAKİ ÇİFT TIRNAK İÇERİÐİNİ DEÐİÞTİREREK
'VEYA ÇİFT TIRNAÐIN ARASINI SİLEREK "" VEYA "," GİBİ
'İSTEÐİNİZ SONUCUN ÇIKMASINI SAÐLAYABİLİRSİNİZ.
YTL = ".-YTL., "
YKR = ".-YKR."

Say = Str$(Sayi#)
virgul = InStr(1, Say, ".")
If virgul Then

'Aşağadaki satır 26,4 Yirmialtı YTL, KIRK YKR olarak okutur.
' (Yirmialtı YTL, DÃ?RT YKR olarak değil)
'İptal etmek isterseniz başına bir ' tek tırnak işareti koyunuz
If Len(Mid(Say, virgul + 1)) = 1 Then Say = Say + "0"

Say = Right$(Say, Len(Say) - virgul)
GoSub cevir

If cevap = "" Then YKR = ""
virgul2 = cevap + YKR
cevap = ""

Say = Str$(Sayi#)
Say = Left$(Say, virgul - 1)
End If
GoSub cevir
If cevap = "" Then YTL = ""
Yaziyla = cevap + YTL + virgul2
Exit Function

cevir:
x = Len(Say)
Say = String$(3 - (x - Int(x / 3) * 3), 48) + Say
x = Len(Say) / 3
For i = 1 To x
uclu = Mid$(Say, Len(Say) - i * 3 + 1, 3)
y = Val(Mid$(uclu, 1, 1))
o = Val(Mid$(uclu, 2, 1))
b = Val(Mid$(uclu, 3, 1))

yazi = ""
If y <> 0 Then
If y > 1 Then yazi = birler$
yazi = yazi + "Yüz "
End If

yazi = yazi + onlar$(o) + birler$(b)

If yazi <> "" Then
If LCase(yazi) = "bir" And i = 2 Then yazi = ""
cevap = yazi + basamak$(i) + cevap
End If
Next i
If Sayi# < 0 Then cevap = "-Eksi-" + cevap
Return
End Function

 

[serbestmali]

Selamlar
yine de sağol üstat

 

[milhanalp]

serbestmali,
Sayın sero ve elm arkadaşların kodları işinizi görmedi herhalde.

yine de sağol üstat

Sanki boşa giden bir uğraştan sonra "üzülmeye değmez" ifadesi gibi bir dil kullanmışsınız.
Oysa her iki dostumuzun da kodları gayet iyi çalışıyor!

 

[serbestmali]

selamlar
yanlış anlaşıldı sanırım
aynı kodlar var anlamında kullanmıştım
özürlerimin kabulu dileğiyle saygılar