• DİKKAT

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

rakamı yazıya çevirme

K

kahramang1

Katılım
21 Şubat 2007
Mesajlar
384
Excel Vers. ve Dili
Microsoft Ev ve Ofis 2016
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
 
Deneyiniz.

C++: 
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
 
Merhaba,
İstediğiniz bu mudur?
Kod: 
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)
 
Merhaba,
Kodu oynamadan da yapabilirsiniz. Elinizde iki seçenek olur.
Kod: 
=+YERİNEKOY(YAZIYACEVIR(A1);" ";"")
 
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.

 
:)

İyi çalışmalar.
 
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
Genişletmek için tıkla ...

228601
 
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.
 
Çü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.
 
Teşekkür ederim. İlk fırsatta deneyip size bilgi vereceğim. Kolay gelsin.
 
kahramang1' Alıntı:
Teşekkür ederim. İlk fırsatta deneyip size bilgi vereceğim. Kolay gelsin.
Genişletmek için tıkla ...
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ı.
 

Ekli dosyalar

  • 2021-06-29.png
    2021-06-29.png
    118 KB · Görüntüleme: 10
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst