Sayıyı yazıya çevirme kod hatası

[kemal turan]

Merhaba,
Aşağıdaki kod sayıyı yazıya çevir kodudur. Forumdan aldım.
4 rakamlı binler sayısının başına "bir" yazsını fazla ekliyor.
Örnek: 1112 rakamını "Bir Bin Yüz On İki LİRA" olarak yazıyor.
Düzeltemedim.
Yardımınızı rica ediyorum
Teşekkürler

Function YAZIYAÇEVİR(Para, Optional PBirim = "LİRA", Optional KBirim = "KURUŞ")
    Dim ParaStr As String
    Dim Lira As String, Kuruş As String
    
    If Not IsNumeric(Para) Then
    YAZIYAÇEVİR = "#DEĞER!"
    Exit Function
    End If
    
    ParaStr = Format(Abs(Para), "0.00")
    
    Lira = Left(ParaStr, Len(ParaStr) - 3)
    Kuruş = Right(ParaStr, 2)
    
    YAZIYAÇEVİR = IIf(Para < 0, "Eksi ", "") & ÇEVİR(Lira) & " " & PBirim & " " & _
                  IIf(Val(Kuruş) <> 0, ÇEVİR(Kuruş) & " " & KBirim & " ", "")
End Function

Private Function ÇEVİR(SayıStr As String) As String
    Dim Rakam(15)
    Dim C(3), Sonuç, E
    
    Birler = Array("", " Bir ", " İki ", " Üç ", " 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 ", "")
    
    SayıStr = String(15 - Len(SayıStr), "0") + SayıStr
    
    For i = 1 To 15
    Rakam(i) = Val(Mid$(SayıStr, i, 1))
    Next i
    
    Sonuç = ""
    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 = "Bir ") Then E = "Bin"
    Sonuç = Sonuç + E
    Next i
    
    If Sonuç = "" Then Sonuç = "Sıfır"
    
    ÇEVİR = UCase(Mid(Sonuç, 1, 1)) + Mid(Sonuç, 2, Len(Sonuç) - 1)
End Function

 

[Necdet]

Merhaba,

Forumda başka fonksiyon bulunuz. Doğru çalışan fonksiyonlar var.

 

[kemal turan]

Merhaba Necdet Hocam,
Bulduğum kodların hepsinde aynı hata var.
doğru link hususunda yardımcı olursanız sevinirim.

 

[kemal turan]

merhaba,
Aşağıdaki kodu bir modüle alarak uyguladım, sorunsuz çalışıyor.
Teşekkür ederim.

Public Function YaziylaTL(cTutar As Currency) As String
Dim cLira As Currency, cKurus As Currency, sStr As String, bEksi As Boolean
If cTutar < 0 Then cTutar = -cTutar: bEksi = True
cTutar = Format(cTutar, "#,##0.00")
cLira = Int(cTutar)
cKurus = Left((cTutar - cLira) * 100, 2)
If cLira = 0 Then
sStr = ""
Else
sStr = Yaziyla(cLira) & " TL"
End If
If cKurus = 0 Then
sStr = sStr & ""
Else
sStr = sStr & IIf(sStr <> "", ", ", "") & Yaziyla(cKurus) & " KR"
End If
If sStr = "" Then sStr = "sıfır"
If bEksi Then sStr = "eksi" & sStr
YaziylaTL = sStr
End Function

Private Function Yaziyla(cTutar As Currency)
Dim a, s, e As String
Dim pozitif, negatif As Boolean
Dim X As Byte
Dim b$(9)
Dim Y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)

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

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

m$(0) = "Trilyon"
m$(1) = "Milyar"
m$(2) = "Milyon"
m$(3) = "Bin"
m$(4) = ""

a = Str(cTutar)
If Left$(a, 1) = " " Then pozitif = 1 Else pozitif = 0
a = Right$(a, Len(a) - 1)
For X = 1 To Len(a)
If (Asc(Mid$(a, X, 1)) > Asc("9")) Or (Asc(Mid$(a, X, 1)) < Asc("0")) Then GoTo hata
Next X
If Len(a) > 15 Then GoTo hata
a = String(15 - Len(a), "0") + a
For X = 1 To 15
v(X) = Val(Mid$(a, X, 1))
Next X
s = ""
For X = 0 To 4
c(1) = v((X * 3) + 1)
c(2) = v((X * 3) + 2)
c(3) = v((X * 3) + 3)
If c(1) = 0 Then
e = ""
ElseIf c(1) = 1 Then
e = "Yüz"
Else
e = b$(c(1)) + "Yüz"
End If
e = e + Y$(c(2)) + b$(c(3))
If e <> "" Then e = e + m$(X)
If (X = 3) And (e = "birbin" Or e = "BirBin") Then e = "Bin"
s = s + e
Next X
If s = "" Then s = "sıfır"
If pozitif = 0 Then s = "eksi" + s
Yaziyla = s '+ " TL"
GoTo tamam
hata: Yaziyla = "HATA"
tamam:
End Function

 

[byfika]

Merhabalar, istediğiniz kodlu örnek ektedir. Açıklama sayfa1 de
Deneyiniz. İyi günler

 

[kemal turan]

Sn.Byfika
Geç cevap için özür dilerim.
Çok teşekkür ederim.
Selametle kalınız.

 

[halit3]

Alternatif linkler

http://www.excel.web.tr/f48/rakamy-yazyya-cevirme-t110954.html
http://www.excel.web.tr/f48/yazyyla-makrosunda-hata-var-t67961.html
http://www.excel.web.tr/f14/sayyyy-yazyya-cevirme-modul-yuvarlama-hatasy-t99803.html