Rakamı yazıya çevirmek

[manisali61]

Arkadaşlar merhaba.
Yine bu siteden aldığım rakamı yazıya çevir kodlarını kullanıyorum..Fakat şöyle bir eklenti yapmak istiyorum :
1) Harflerin tümü BÜYÜK HARF olsun
2) Fiyatlar arasında boşluk olmasın (Örneğin BİN İKİ YÜZ ELLİ LİRA değil de BİNİKİYÜZELLİ LİRA şeklinde yazsın.
3) Eğer kuruş hanesi 00 ise 00 KR değilde boş bıraksın.(Örneğin :
BİNELLİ TL 00 KR değil,BİNELLİ TL yazsın)
Kodları aşağıya kopyalıyorum.
Şimdiden teşekkürler

Kodlar şöyle idi :

Public Function ParaCevir(Para)
Dim ParaStr As String
Dim TL As String, Kurus As String
If Not IsNumeric(Para) Then GoTo SayiDegil
ParaStr = Format(Abs(Para), "0.00")
TL = Left(ParaStr, Len(ParaStr) - 3)
Kurus = Right(ParaStr, 2)
ParaCevir = IIf(Para < 0, "Eksi ", "") & Cevir(TL) & " TL " & Cevir(Kurus) & " Krs"
Exit Function
SayiDegil:
ParaCevir = "GİRİLEN DEĞER SAYI DEĞİL!"
End Function
Sub bicim4()
'/- sayıları yuvarla
'/- 100 sayısını döndürür
[A2].Value = Int(100.4 + 0.5)
End Sub
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 = "00"
Cevir = UCase(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1)
End Function

 

[uzmanamele]

alternatif olsun

=tl_yaz(A1) şeklinde kullanabilirsiniz.
büyük harf istiyorsanız kod içindeki rakamları büyük harfe çeviriniz. (Beş yerine BEŞ gibi)

Function tl_yaz(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "Bir", "İki", "Üç", "Dört", "Beş", "Altı", "Yedi", "Sekiz", "Dokuz")
b = Array("", "On", "Yirmi", "Otuz", "Kırk", "Elli", "Altmış", "Yetmiş", "Seksen", "Doksan")
c = Array("", "", "Bin", "Milyon", "Milyar", "Trilyon")
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", "BirYü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) = "BirBin" Then son = Replace(son, "BirBin", "Bin")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then tl = son & " TürkLirası"
If g = 2 And deger(2) <> 0 Then kr = " " & son & " Kuruş"
son = ""
e = 0
Next
tl_yaz = tl & kr
End Function

 

[manisali61]

Üstadım harika olmuş..teşekkür ederim

 

[Vedat Özer]

Altarnatif olarak Uzmanların Hazırlamış oldugu bir eklenti dosyası var bunu
araçlar/eklenti/gözattan ekleyip her çalışma sayfası için geçerli olur
iyi günler

 

[manisali61]

Vedat72 arkadaşım..Ya ben açamadım,ya da gönderdiğin dosya açılmıyor..

 

[İhsan Tank]

Vedat72 arkadaşım..Ya ben açamadım,ya da gönderdiğin dosya açılmıyor..

merhaba
bu eklenti açmayıp arkadaşın söylediği yolla eklentilere eklersen farkını görürsün ( ben tavsiye etmiyorum )

 

[Vedat Özer]

tıkla
burda detaylı açıklıyo

 

[manisali61]

Tamam üstad.Teşekkürler..

 

[hsnyvz]

Ekli dosyayı görüntüle tl_yaz.xla

Bu eklentideki birbin ve bir yüz sorunu halledemedim..
Bu sorunu nasıl çözerim?

Teşekkürler..

 

[İhsan Tank]

Ekli dosyayı görüntüle 92215

Bu eklentideki birbin ve bir yüz sorunu halledemedim..
Bu sorunu nasıl çözerim?

Teşekkürler..

buyrun dosyanız değiştirildi

 

[hsnyvz]

çok teşekkürler sayın İhsan,

rakamlar arasında boşluk bırakmayı denedim,yine aynı hatayı aldım..
acaba "BİN ÜÇ YÜZ KIRK BEŞ TL." gibi yazdırmak mümkünmü?

 

[İhsan Tank]

çok teşekkürler sayın İhsan,

rakamlar arasında boşluk bırakmayı denedim,yine aynı hatayı aldım..
acaba "BİN ÜÇ YÜZ KIRK BEŞ TL." gibi yazdırmak mümkünmü?

merhaba
bu şekil de oluyor dilerseniz
bin üçyüz kırkbeş tl dilerseniz göndereyim

 

[hsnyvz]

TESEKKÜRLER SN İHSAN,
sanırım bütün rakamları ayırmanın yolu yok..
daha önce gönderdiğiniz hali ile kullanayım şimdilik..
Teşekkürler,hayırlı Kandiller..

 

[İhsan Tank]

TESEKKÜRLER SN İHSAN,
sanırım bütün rakamları ayırmanın yolu yok..
daha önce gönderdiğiniz hali ile kullanayım şimdilik..
Teşekkürler,hayırlı Kandiller..

rica ederim
Size'de hayırlı Kandiller
Kolay Gelsin :mutlu:

 

[jerpi]

office 2010 da denedim ama olmadı. acaba nerde hata yapıyorum.

 

[İhsan Tank]

office 2010 da denedim ama olmadı. acaba nerde hata yapıyorum.

nerede hata alıyorsunuz önce onu anlatırsanız yardımcı olmaya çalışalım

 

[eren06]

merhabalar bende de office 2010'da çalışmıyor, hata da vermiyor. Dosyayı açtığınızda çalışıyor. Excell'i kapatıp açtığınızda ise yüklemiyor.
Office 2010'da addins klasürüne ytleklentisi.xla'yı kopyaladım. (C:\Users\ilhan \AppData\Roaming\Microsoft\AddIns)
Geliştirici menüsünden kullanılabilir tüm eklentiler bölümündeki (ytleklentisi.xla da dahil) hepsini işaretledim. çözücü eklentisi vb...
Ama yukarıda da anlattığım gibi kendiliğinden çalışmıyor.
Yardımlarınız için şimdiden teşekkür ederim.

 

[champion82]

rakamı yazıya çevirme

Merhabalar,

Makroyu excelde kod olarak çalıştırdım. fakat bu durumun tüm çalışma kitaplarında olması için nasıl bir işlem yapmam lazım. Yardımcı olabilirseniz çok sevinirim.