YENİ TL ve KURUŞA ÇEVİR

[renklikedi]

Selamlar... Var olan bir makro üzerinde biraz kafa yorarak RAKAMLA girilen YTL cinsinden değeri YAZIYA çevirmeyi başardım ama bir sorunla karşılaştım. Virgülden sonraki onlu değerleri birlik değer olarak görüyor. Ã?rneğin 10,50 değerini yazıya çevirirken 10 YTL 5 Kuruş olarak görüyor. Ancak 10,58 gibi bir değer 10 YTL 58 Kuruş olarak çevrilebiliyor. Virgülden sonra 10'lu değerler; niçin birlik değer olarak gözüküyordur... Kod aşağıda... İYİ BAYRAMLAR...
=====
Function KURUS(Sayi#)

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$ = "": onda$ = ""

Say$ = Str$(Sayi#)
virgul% = InStr(2, Say$, ".")
If virgul% Then
Say$ = Right$(Say$, Len(Say$) - virgul%)
Select Case Len(Say$)
Case 2: onda$ = "Kuruş"
Case 1: onda$ = "Kuruş"
End Select
GoSub cevir

virgul2$ = " YTL. " + cevap$ + " " + onda$
cevap$ = ""

Say$ = Str$(Sayi#)
Say$ = Left(Say$, virgul% - 1)
End If
GoSub cevir
KURUS = cevap$ + 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$(Y%)
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%
Return
End Function

[xxrt]

http://www.excel.web.tr/viewtopic.php?t=385&highlight=ytl birde bu fonksiyonu denermisiniz..
Sizin fonksiyonla elde edilen sonuç
OnBeş YTL. ElliSekiz Kuruş
Benim önerdiğim fpnksiyonla elde edilen sonuç:
Onbeş Lira Ellisekiz Kuruş
Yanlış anladıysam belirtiniz..

Ã?nerdiğim Kodlar.
Public Function ParaCevir(Para)
Dim ParaStr As String
Dim Lira As String, Kurus As String

If Not IsNumeric(Para) Then GoTo SayiDegil

ParaStr = Format(Abs(Para), "0.00")

Lira = Left(ParaStr, Len(ParaStr) - 3)
Kurus = Right(ParaStr, 2)

ParaCevir = IIf(Para < 0, "Eksi ", "") & Cevir(Lira) & " Lira " & Cevir(Kurus) & " Kuruş"

Exit Function

SayiDegil:
ParaCevir = "GİRİLEN DEÃ�ER SAYI DEÃ�İL!"
End Function

Private Function Cevir(SayiStr As String) As String
Dim Rakam(15)
Dim c(3), Sonuc, e

Birler = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
Onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
Binler = Array("trilyon", "milyar", "milyon", "bin", "")

SayiStr = String(15 - Len(SayiStr), "0") + SayiStr

For i = 1 To 15
Rakam(i) = Val(Mid$(SayiStr, i, 1))
Next i

Sonuc = ""
For i = 0 To 4
c(1) = Rakam(i * 3 + 1)
c(2) = Rakam(i * 3 + 2)
c(3) = Rakam(i * 3 + 3)
If c(1) = 0 Then
e = ""
ElseIf c(1) = 1 Then
e = "yüz"
Else
e = Birler(c(1)) + "yüz"
End If
e = e + Onlar(c(2)) + Birler(c(3))
If e <> "" Then e = e + Binler(i)
If (i = 3) And (e = "birbin") Then e = "bin"
Sonuc = Sonuc + e
Next i

If Sonuc = "" Then Sonuc = "Sıfır"

Cevir = UCase(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1)
End Function

[drmurat]

modül1 e kopyaladığımız bu makroyu pc deki tüm excel belgelerinin tanıması için ve buradaki belgeyi başka bir pc ye aldığımızda o pc nin de aynı şekilde tüm belgelerinde tanıması için ne yapabiliriz?yardımcı olursanız sevinirim saygılar!

[xxrt]

Boş Bir excel Sayfası açarak Alt+F11 tuşu ile İlgili kodları modüle yapıştırın..
Daha sonra bu dosyayı Kaydederken Microsoft Exel Eklentisi olarak Addıns klasörü altına kaydedin..Daha sonraÇalışma Dosyası açarak Araçlar>Eklentiler den Bu kaydettiğiniz dosyayı işaretleyin bukadar.Herçalışmanızda =KURUS fonksiyonunuz çalışacaktır.
Başka bir PC'ye kopyalandığında ya o çalışmayı setup olarak hazırlayıp xla eklentisini ilgili yere kuracaksınız yada yukarıdaki işlemleri birkereye mahsuz o Pc'dede yapacaksınız..

Ayrıca Burayada Bakabilirsiniz. (http://www.excel.web.tr/viewtopic.php?t=154&highlight=xla)

[drmurat]

yardım için teşekkürler
hepinize kolay gelsin