rakamı yazıya çevirme

[kahramang1]

Merhaba arkadaşlar. elimde ekte vermiş olduğum bir kod var. Burada örneğin 73.895,84 TL yi yazı ile "Yalnız Yetmişüçbinsekizyüzdoksanbeş Türk Lirası Seksendört Kuruş." olarak yazıyor. Sizlerden ricam Türk Lirası ve Kuruş yazılarının aralarındaki boşluğu kaldırmanız olacak. Yani "Yalnız YetmişüçbinsekizyüzdoksanbeşTürkLirasıSeksendörtKuruş." olarak yazmasıdır. Teşekkürler.

Public Function YAZIYACEVIR(Para_Tutar)

Dim Para_TutarStr As String
Dim ParaBirimi As String, ParaAltBirimi As String

HücreAdı = Para_Tutar.Address

If Para_Tutar = "" Then
YAZIYACEVIR = HücreAdı & " Hücresine bir değer girmelisiniz !..."
Exit Function
End If

If Not IsNumeric(Para_Tutar) Then
YAZIYACEVIR = HücreAdı & " Hücresine girilen değer, sayı değil !..."
Exit Function
End If

ParaStr = Format(Abs(Para_Tutar), "0.00")
ParaBirimi = Left(ParaStr, Len(ParaStr) - 3)
ParaAltBirimi = Right(ParaStr, 2)

YAZIYACEVIR = IIf(Para_Tutar = 0, "Yalnız " & Cevir(ParaBirimi) & "Türklirası ", "") & _
IIf(Para_Tutar <> 0, "Yalnız ", "") & _
IIf(Para_Tutar < 0, "Eksi (-) ", "") & _
IIf(Para_Tutar <> 0, Cevir(ParaBirimi) & "Türk Lirası", "") & _
IIf(Val(ParaAltBirimi) <> 0, Cevir(ParaAltBirimi) & "Kuruş.", "")

If ParaBirimi = 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız " & Cevir(ParaAltBirimi) & " Kuruş."

If Para_Tutar < 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız Eksi (-) " & Cevir(ParaAltBirimi) & " Kuruş."

End If

End If

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

 

[Korhan Ayhan]

Deneyiniz.

Public Function YAZIYACEVIR(Para_Tutar)

Dim Para_TutarStr As String
Dim ParaBirimi As String, ParaAltBirimi As String

HücreAdı = Para_Tutar.Address

If Para_Tutar = "" Then
YAZIYACEVIR = HücreAdı & " Hücresine bir değer girmelisiniz !..."
Exit Function
End If

If Not IsNumeric(Para_Tutar) Then
YAZIYACEVIR = HücreAdı & " Hücresine girilen değer, sayı değil !..."
Exit Function
End If

ParaStr = Format(Abs(Para_Tutar), "0.00")
ParaBirimi = Left(ParaStr, Len(ParaStr) - 3)
ParaAltBirimi = Right(ParaStr, 2)

YAZIYACEVIR = IIf(Para_Tutar = 0, "Yalnız " & Cevir(ParaBirimi) & "TürkLirası", "") & _
IIf(Para_Tutar <> 0, "Yalnız ", "") & _
IIf(Para_Tutar < 0, "Eksi (-) ", "") & _
IIf(Para_Tutar <> 0, Cevir(ParaBirimi) & "TürkLirası", "") & _
IIf(Val(ParaAltBirimi) <> 0, Cevir(ParaAltBirimi) & "Kuruş.", "")

If ParaBirimi = 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız " & Cevir(ParaAltBirimi) & "Kuruş."

If Para_Tutar < 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız Eksi (-) " & Cevir(ParaAltBirimi) & "Kuruş."

End If

End If

End Function

 

[Tevfik_Kursun]

Merhaba,
İstediğiniz bu mudur?

Public Function YAZIYACEVIR(Para_Tutar)

Dim Para_TutarStr As String
Dim ParaBirimi As String, ParaAltBirimi As String

HücreAdı = Para_Tutar.Address

If Para_Tutar = "" Then
YAZIYACEVIR = HücreAdı & " Hücresine bir değer girmelisiniz !..."
Exit Function
End If

If Not IsNumeric(Para_Tutar) Then
YAZIYACEVIR = HücreAdı & " Hücresine girilen değer, sayı değil !..."
Exit Function
End If

ParaStr = Format(Abs(Para_Tutar), "0.00")
ParaBirimi = Left(ParaStr, Len(ParaStr) - 3)
ParaAltBirimi = Right(ParaStr, 2)

YAZIYACEVIR = IIf(Para_Tutar = 0, "Yalnız " & Cevir(ParaBirimi) & "Lira", "") & _
IIf(Para_Tutar <> 0, "Yalnız ", "") & _
IIf(Para_Tutar < 0, "Eksi (-) ", "") & _
IIf(Para_Tutar <> 0, Cevir(ParaBirimi) & "Lira", "") & _
IIf(Val(ParaAltBirimi) <> 0, Cevir(ParaAltBirimi) & "Kuruş.", "")

If ParaBirimi = 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız " & Cevir(ParaAltBirimi) & "Kuruş."

If Para_Tutar < 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız Eksi (-) " & Cevir(ParaAltBirimi) & "Kuruş."

End If

End If

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

İyi çalışmalar (benmki de alternatif olsun)

 

[Mahir64]

Merhaba,
Kodu oynamadan da yapabilirsiniz. Elinizde iki seçenek olur.

=+YERİNEKOY(YAZIYACEVIR(A1);" ";"")

 

[kahramang1]

maalesef iki kodda da Türk Lirası ve Kuruş Haneleri arasında boşluk var

Yalnız Yetmişüçbinsekizyüzdoksanbeş Türk Lirası Seksendört Kuruş. "Yalnız YetmişüçbinsekizyüzdoksanbeşTürkLirasıSeksendörtKuruş"olmasını istediğim format budur.

 

[kahramang1]

Merhaba,
Kodu oynamadan da yapabilirsiniz. Elinizde iki seçenek olur.

=+YERİNEKOY(YAZIYACEVIR(A1);" ";"")

bu kod problemi çözdü. Çok teşekkür ederim
kolay gelsin.

 

[Mahir64]

İyi çalışmalar.

 

[Korhan Ayhan]

Merhaba,

Ben kodu deneyerek paylaştım. Doğru uyguladığınıza emin misiniz?

maalesef iki kodda da Türk Lirası ve Kuruş Haneleri arasında boşluk var

 

[kahramang1]

Uygulamada hata yapmış olabilirim. Benim yaptığım, mevcut kodu tamamen silip, sizin gönderdiğiniz kodu buradan kopyalayıp yapıştırmak oldu. Makro konusunda hiç bilgim yok. Yeni modül mü eklemem gerekiyordu onu bilemiyorum. Bu konuda da bilgi verirseniz o konuyu da öğrenmiş olurum. Teşekkürler ilginiz için.

 

[kahramang1]

Merhaba,

Ben kodu deneyerek paylaştım. Doğru uyguladığınıza emin misiniz?



Ekli dosyayı görüntüle 228601

birde mevcut kod 2 bölümden oluşuyor. Sanırım siz sadece üst kısmı göndermişsiniz. Ondan olabilir mi?

 

[Korhan Ayhan]

Çünkü diğer kısımda değişikliğe gerek yoktu. Bunun için sadece değişen bölümü paylaştım. İkinci bölümü benim paylaştığım kısmın altına eklerseniz sonuç alabilirsiniz.

Burada kimsenin bilgi seviyesini bilemediğimiz için belirtilmediği sürece uyarlama yapılabileceğini düşünerek hareket ediyoruz.

 

[kahramang1]

Teşekkür ederim. İlk fırsatta deneyip size bilgi vereceğim. Kolay gelsin.

 

[kahramang1]

Teşekkür ederim. İlk fırsatta deneyip size bilgi vereceğim. Kolay gelsin.

problemin nereden kaynaklandığını anladım. Ekli resimde görüldüğü gibi yazdığınız fonksiyonu kopyalayıp yapıştırdığımda sağ üst köşede "çevir" başlığı çıkıyordu. Açılır pencereden "yazıya çevir" seçeneğeni tıkladığımda kod düzgün çalıştı.