• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Parayı yazıya Çevirme

J

jseramsi

Katılım
4 Eylül 2006
Mesajlar
20
Excel Vers. ve Dili
2003
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
 

Ekli dosyalar

Aşağıdaki kodları deneyin. Formülü kullanırken =Çevir demeniz lazım.
Kod: 
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
 
hücreye =Çevir ekleyip mesela =Çevir(C1) yazdığımda hata veriyor bu şekilde değilmiydi yoksa
 
eki inceleyiniz ( metin karaağaç uzman'ın gönderdiği kod )
 

Ekli dosyalar

kodda sanırım hata var... birde sanırım kuruşu çevirmiyor
 
wezyr' Alıntı:
kodda sanırım hata var... birde sanırım kuruşu çevirmiyor
Genişletmek için tıkla ...

Kod: 
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
 

Ekli dosyalar

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.
 

Ekli dosyalar

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.
 
muhasebeciyiz' Alıntı:
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.
Genişletmek için tıkla ...

Emeğinize sağlık çok teşekkür ederim, özellikle butonsuz halledebildiğimiz için
 
'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
 

Ekli dosyalar

mhaluksen' Alıntı:
'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
Genişletmek için tıkla ...
sn. @muhasebeciyiz 'in vermiş olduğu kod sorunsuz çalışıyor. ne demek istediğinizi anlamadım
 
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.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst