Parayı yazıya Çevirme

[jseramsi]

Parayı yazıya çevirme dosyasında 1.357,00 tl yi çevirirken BİRBİNÜÇYÜZELLİYEDİ TL diye çeviriyor yazının en başına BİR ekliyor bunun neresinde hata var acaba... yardımcı olurmusunuz... kolay gelsin

 

[Metin Karaağaç]

Aşağıdaki kodları deneyin. Formülü kullanırken =Çevir demeniz lazım.

Private Function Çevir(SayiStr As String) As String
    Dim Rakam(15)
    Dim c(3), Sonuc, 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 ", "")
    
    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"
    
    Çevir = UCase(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1)
End Function

 

[jseramsi]

hücreye =Çevir ekleyip mesela =Çevir(C1) yazdığımda hata veriyor bu şekilde değilmiydi yoksa

 

[İhsan Tank]

eki inceleyiniz ( metin karaağaç uzman'ın gönderdiği kod )

 

[wezyr]

kodda sanırım hata var... birde sanırım kuruşu çevirmiyor

 

[1903bjk]

Merhaba,

Ekteki örneği inceleyiniz

 

[İhsan Tank]

kodda sanırım hata var... birde sanırım kuruşu çevirmiyor

Function tl_yaz(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "BİR", "İKİ", "ÜÇ", "DÖRT", "BEŞ", "ALTI", "YEDİ", "SEKİZ", "DOKUZ")
b = Array("", "ON", "YİRMİ", "OTUZ", "KIRK", "ELLİ", "ALTMIŞ", "YETMİŞ", "SEKSEN", "DOKSAN")
c = Array("", "", "BİN", "MİLYON", "MİLYAR", "TRİLYON")
deger(1) = Int(sayi)
deger(2) = Round(sayi - deger(1), 2) * 100
If sayi = 0 Then son = "sıfır"
For g = 1 To 2
yazi = deger(g)
For d = 1 To Len(yazi) Step 3
e = e + 1
deg(1) = Mid(yazi, Len(yazi) - d - 1, 1)
deg(2) = Mid(yazi, Len(yazi) - d, 1)
deg(3) = Mid(yazi, Len(yazi) - d + 1, 1)
If deg(1) <> 0 Then s(1) = Replace(a(deg(1)) & "YÜZ", "BİRYÜZ", "YÜZ")
s(2) = b(deg(2))
s(3) = a(deg(3)) & c(e)
If deg(1) + deg(2) + deg(3) = 0 Then s(3) = ""
son = s(1) & s(2) & s(3) & son
If Left(son, 6) = "BİRBİN" Then son = Replace(son, "BİRBİN", "BİN")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then tl = son & " TÜRKLİRASI"
If g = 2 And deger(2) <> 0 Then kr = " " & son & " KURUŞ"
son = ""
e = 0
Next
tl_yaz = tl & kr
End Function

uzmanamele ( teşekkür ediyorum ) hocam'dan alıdığım kod
eki inceleyiniz

 

[mc_exrem]

Merhabalar

forumda birçok örnek var ama bir türlü kodları çalıştıramadım

=@tl_yaz(F19) fonkisyonu ile

Function tl_yaz(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "BİR", "İKİ", "ÜÇ", "DÖRT", "BEŞ", "ALTI", "YEDİ", "SEKİZ", "DOKUZ")
b = Array("", "ON", "YİRMİ", "OTUZ", "KIRK", "ELLİ", "ALTMIŞ", "YETMİŞ", "SEKSEN", "DOKSAN")
c = Array("", "", "BİN", "MİLYON", "MİLYAR", "TRİLYON")
deger(1) = Int(sayi)
deger(2) = Round(sayi - deger(1), 2) * 100
If sayi = 0 Then son = "sıfır"
For g = 1 To 2
yazi = deger(g)
For d = 1 To Len(yazi) Step 3
e = e + 1
deg(1) = Mid(yazi, Len(yazi) - d - 1, 1)
deg(2) = Mid(yazi, Len(yazi) - d, 1)
deg(3) = Mid(yazi, Len(yazi) - d + 1, 1)
If deg(1) <> 0 Then s(1) = Replace(a(deg(1)) & "YÜZ", "BİRYÜZ", "YÜZ")
s(2) = b(deg(2))
s(3) = a(deg(3)) & c(e)
If deg(1) + deg(2) + deg(3) = 0 Then s(3) = ""
son = s(1) & s(2) & s(3) & son
If Left(son, 6) = "BİRBİN" Then son = Replace(son, "BİRBİN", "BİN")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then tl = son & " TÜRKLİRASI"
If g = 2 And deger(2) <> 0 Then kr = " " & son & " KURUŞ"
son = ""
e = 0
Next
tl_yaz = tl & kr
End Function

kodunu çalıştırmak istedim ama olmadı.

Yapmak istediğim her iki sayfadaki F6 hücresindeki veriyi A20 ve A46 hücrelerine yazıya çevirmesini istiyorum.
Yardımlarınız için şimdiden teşekkürler.

 

[muhasebeciyiz]

Function tl_yaz(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "BİR", "İKİ", "ÜÇ", "DÖRT", "BEŞ", "ALTI", "YEDİ", "SEKİZ", "DOKUZ")
b = Array("", "ON", "YİRMİ", "OTUZ", "KIRK", "ELLİ", "ALTMIŞ", "YETMİŞ", "SEKSEN", "DOKSAN")
c = Array("", "", "BİN", "MİLYON", "MİLYAR", "TRİLYON")
deger(1) = Int(sayi)
deger(2) = Round(sayi - deger(1), 2) * 100
If sayi = 0 Then son = "sıfır"
For g = 1 To 2
yazi = deger(g)
For d = 1 To Len(yazi) Step 3
e = e + 1
deg(1) = Mid(yazi, Len(yazi) - d - 1, 1)
deg(2) = Mid(yazi, Len(yazi) - d, 1)
deg(3) = Mid(yazi, Len(yazi) - d + 1, 1)
If deg(1) <> 0 Then s(1) = Replace(a(deg(1)) & "YÜZ", "BİRYÜZ", "YÜZ")
s(2) = b(deg(2))
s(3) = a(deg(3)) & c(e)
If deg(1) + deg(2) + deg(3) = 0 Then s(3) = ""
son = s(1) & s(2) & s(3) & son
If Left(son, 6) = "BİRBİN" Then son = Replace(son, "BİRBİN", "BİN")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then tl = son & " TÜRKLİRASI"
If g = 2 And deger(2) <> 0 Then kr = " " & son & " KURUŞ"
son = ""
e = 0
Next
tl_yaz = tl & kr
End Function

1-Tahsilat makbuzu sayfanız içinde bulunan modüle1 içindeki kodları siliniz.
2- Yerine yukarda İhsan Tank tarafından paylaşılmış olan kodları kopyalayıp yapıştırınız.
3- Sayfanıza dönerek gençeller sayfasındaki F20 hücresine F2 tuşu ile girip enter yapınız.

 

[mc_exrem]

Function tl_yaz(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "BİR", "İKİ", "ÜÇ", "DÖRT", "BEŞ", "ALTI", "YEDİ", "SEKİZ", "DOKUZ")
b = Array("", "ON", "YİRMİ", "OTUZ", "KIRK", "ELLİ", "ALTMIŞ", "YETMİŞ", "SEKSEN", "DOKSAN")
c = Array("", "", "BİN", "MİLYON", "MİLYAR", "TRİLYON")
deger(1) = Int(sayi)
deger(2) = Round(sayi - deger(1), 2) * 100
If sayi = 0 Then son = "sıfır"
For g = 1 To 2
yazi = deger(g)
For d = 1 To Len(yazi) Step 3
e = e + 1
deg(1) = Mid(yazi, Len(yazi) - d - 1, 1)
deg(2) = Mid(yazi, Len(yazi) - d, 1)
deg(3) = Mid(yazi, Len(yazi) - d + 1, 1)
If deg(1) <> 0 Then s(1) = Replace(a(deg(1)) & "YÜZ", "BİRYÜZ", "YÜZ")
s(2) = b(deg(2))
s(3) = a(deg(3)) & c(e)
If deg(1) + deg(2) + deg(3) = 0 Then s(3) = ""
son = s(1) & s(2) & s(3) & son
If Left(son, 6) = "BİRBİN" Then son = Replace(son, "BİRBİN", "BİN")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then tl = son & " TÜRKLİRASI"
If g = 2 And deger(2) <> 0 Then kr = " " & son & " KURUŞ"
son = ""
e = 0
Next
tl_yaz = tl & kr
End Function

1-Tahsilat makbuzu sayfanız içinde bulunan modüle1 içindeki kodları siliniz.
2- Yerine yukarda İhsan Tank tarafından paylaşılmış olan kodları kopyalayıp yapıştırınız.
3- Sayfanıza dönerek gençeller sayfasındaki F20 hücresine F2 tuşu ile girip enter yapınız.

Emeğinize sağlık çok teşekkür ederim, özellikle butonsuz halledebildiğimiz için

 

[mhaluksen]

'Mesut Akcan ustamdan alıntıdır. Ben şu an bunu kullanmaktayım hiç bir sorun yoktur
'Anamur Endüstri Meslek Lisesi
'Metal İşleri Bölüm Şefi
'
'akcan@mesut.web.tr
'
'Parasal Rakamı yazıyla yazar
'
'01/11/2004
'güncelleme: 8 Ocak 2005

'tür=0 TL ve KRŞ
' 1 Yalnız TL
' 2 Tam sayı ise yalnız TL

 

[mc_exrem]

'Mesut Akcan ustamdan alıntıdır. Ben şu an bunu kullanmaktayım hiç bir sorun yoktur
'Anamur Endüstri Meslek Lisesi
'Metal İşleri Bölüm Şefi
'
'akcan@mesut.web.tr
'
'Parasal Rakamı yazıyla yazar
'
'01/11/2004
'güncelleme: 8 Ocak 2005

'tür=0 TL ve KRŞ
' 1 Yalnız TL
' 2 Tam sayı ise yalnız TL

sn. @muhasebeciyiz 'in vermiş olduğu kod sorunsuz çalışıyor. ne demek istediğinizi anlamadım

 

[ulutanas]

Merhaba daha önceden aynı konu ile ilgili bende yardım almıştım. Şu an kullanmış olduğum modülü yeni bir dosyaya kaydettim. Umarım sizinde işinize yarar.