YENİ TL ve KURUŞA ÇEVİR

[renklikedi]

YENÝ TL ve KURUÞA ÇEVÝR

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.

 

[drmurat]

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