YAZIYLA YTL

[talatcd]

aşağıdaki kodu kopyala yapıştır yaptıktan sonra
Yazıya çevrilecek hücreye =YAZIYLAYTL(sayının bulunduğu hücreyi seç)
Function YAZIYLAYTL(sayi, Optional tür As Byte = 0)
'Parasal Rakamı yazıyla yazar
'
'Talat ÇELİKDEMİR
'Elazığ İl Milli Eğitim Müdürlüğü
'Mutemedi
'
'http://talatcd.sitemynet.com/Talat/
'talatcd@hotmail.com
'
'01/11/2004

'tür=0 YTL ve YKR
' 1 Yalnız YTL
' 2 Tam sayı ise yalnız YTL

Dim tam
Dim küsur As Byte
Dim syazi As String

If IsNumeric(sayi) And Len(Format(sayi)) < 16 Then
sayi = Int(sayi * 100) / 100
If sayi < 0 Then
syazi = "Eksi "
sayi = Abs(sayi)
End If
tam = Int(sayi)
küsur = (sayi - tam) * 100
syazi = syazi & yçevir(tam) & " YTL "
If tür = 0 Or (tür = 2 And küsur <> 0) Then
syazi = syazi & yçevir(küsur) & " YKR"
End If
Else
syazi = "Hata"
End If
YAZIYLAYTL = syazi
End Function

 

[Haluk]

Merhaba;

Bununla birlikte kullanılması gereken "yçevir" isimli fonksiyonu da eklemeniz gerekir...

 

[talatcd]

YAZIYLAYTL

Function YAZIYLAYTL(sayi, Optional tür As Byte = 0)
'Parasal Rakamı yazıyla yazar
'
'Talat ÇELİKDEMİR
'Elazığ İl Milli Eğitim Müdürlüğü
'Mutemedi
'
'http://talatcd.sitemynet.com/Talat/
'talatcd@hotmail.com
'
'01/11/2004

'tür=0 YTL ve YKR
' 1 Yalnız YTL
' 2 Tam sayı ise yalnız YTL

Dim tam
Dim küsur As Byte
Dim syazi As String

If IsNumeric(sayi) And Len(Format(sayi)) < 16 Then
sayi = Int(sayi * 100) / 100
If sayi < 0 Then
syazi = "Eksi "
sayi = Abs(sayi)
End If
tam = Int(sayi)
küsur = (sayi - tam) * 100
syazi = syazi & yçevir(tam) & " YTL "
If tür = 0 Or (tür = 2 And küsur <> 0) Then
syazi = syazi & yçevir(küsur) & " YKR"
End If
Else
syazi = "Hata"
End If
YAZIYLAYTL = syazi
End Function

Function yçevir(csayi)
Dim birler, onlar, bsayi
Dim rakamlar(1 To 15) As Byte
Dim yazi As String, syazi As String
Dim uz As Byte
Dim m
Dim sayi As String
Dim bs As Byte
Dim art As Byte
Dim rakam As Byte

birler = Array("", "Bir", "İki", "Üç", "Dört", "Beş", "Altı", "Yedi", "Sekiz", "Dokuz")
onlar = Array("", "On", "Yirmi", "Otuz", "Kırk", "Elli", "Altmış", "Yetmiş", "Seksen", "Doksan")
bsayi = Array("", "Bin ", "Milyon ", "Milyar ", "Trilyon ")

sayi = Format(csayi)
uz = Len(sayi)
For m = uz To 1 Step -1
art = art + 1
rakamlar(art) = Val(Mid(sayi, m, 1))
Next
For bs = 1 To uz
art = bs Mod 3
rakam = rakamlar(bs)
yazi = ""
Select Case art
Case 1
yazi = birler(rakam) & bsayi(Int(bs / 3))
If uz = 4 And yazi = "BirBin " Then yazi = "Bin "
Case 2
yazi = onlar(rakam)
Case 0
If rakam = 0 Then
yazi = ""
ElseIf rakam = 1 Then
yazi = "Yüz"
Else
yazi = birler(rakam) & "Yüz"
End If
End Select
syazi = yazi & syazi
Next
If syazi = "" Then
syazi = "Sıfır"
Else
syazi = Replace(syazi, " Bin ", "")
syazi = Replace(syazi, " Milyar ", "")
syazi = Replace(syazi, " Milyon ", "")
End If
yçevir = syazi
End Function

 

[selo623]

SLM EXCELL SEVERLER;BENDE BU KONUDA YARDIM ETMEK İSTERİM AÞAGIDA YAZILI FORMÜLLERİ BİR KENARA KOPYALA YAPIÞTIR HER EXCEELL SAYFASINDA YTL Yİ YAZIYA CEVİRMEK İSTEDİÐİN ZAMAN ÞU ANLATACAÐIM SIRAYA GÃ?RE İÞLEM YAP.1-KOPYALAMA YAPTIÐIN AÞAÐIDAKİ FORMÜLLERİ EXCELL SAYFASINDA İKEN ALT TUÞUNA BASILI TUTARKEN F11 E BAS.KARÞIMIZA VİSUAL BASİC SAYFASI ÇIKAR ;ÜSTTE İNSERT TIKLA MODULE GEL ONUDA TIKLA VE AÇ AÇILAN SAYFAYA MAUSLA SAÐ TIKLA VE PASTE YAP(YAPIÞTIR).OK ÞİMDİ KAPAT BUNDAN SONRA İSTEDİÐİN HANGİ HÜCREDE YAZI İLE İSTİYORSAN HÜCREYE GEL VE =paracevir(rakamla yazılı hücreyi seç) ENTER.BİTTİ HAYIRLI OLSUN BEN BİLMEDİÐİMİ BU SİTEDEKİ YARDIM SEVER İNSANLARDAN Ã?ÐRENMEYE ÇALIÞIYORUM BEN DE SİZLERE YARDIMCI OLABİLİYORSAM NE MUTLU TÞK. :mutlu: :mutlu: :mutlu: :hey: :hey:

 

[selo623]

public Function ParaCevir(Para)
Dim ParaStr As String
Dim YTLira As String, Kurus As String

If Not IsNumeric(Para) Then GoTo SayiDegil

ParaStr = Format(Abs(Para), "0.00")

YTLira = Left(ParaStr, Len(ParaStr) - 3)
Kurus = Right(ParaStr, 2)

ParaCevir = IIf(Para < 0, "Eksi ", "") & Cevir(YTLira) & " YTLira " & Cevir(Kurus) & " YKr."

Exit Function

SayiDegil:
ParaCevir = "GİRİLEN DEÐER SAYI DEÐİL!"
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

 

[aliakgul]

YTL ve YKR değerlerini yazıya çevirme

Sevgili arkadaşlar, bende de şöyle birşeyler var.Meraklısına.... :wink:
Ã?nemle belirtmek isterim ki; bu kendi eserim DEÐİLDİR.[Emeğe saygı açısından bunu belirtmek istiyorum....]

Function Yaziyla(sayi#)
Dim virgul2 As String
Dim cevap As String
Dim yazi As String
Dim Say As String
Dim uclu As String
Dim virgul As Integer
Dim o As Integer
Dim b As Integer
Dim x As Integer
Dim i As Integer
Dim y As Integer
Dim YTL As String
Dim YKR As String

If sayi# = 0 Then Yaziyla = "Sıfır": Exit Function

ReDim birler$(10), onlar$(10), basamak$(5)

birler$(0) = "":
birler$(1) = "Bir"
birler$(2) = "iki"
birler$(3) = "üç"
birler$(4) = "dört"
birler$(5) = "beş"
birler$(6) = "altı"
birler$(7) = "yedi"
birler$(8) = "sekiz"
birler$(9) = "dokuz"

onlar$(0) = ""
onlar$(1) = "on"
onlar$(2) = "yirmi"
onlar$(3) = "otuz"
onlar$(4) = "kırk"
onlar$(5) = "elli"
onlar$(6) = "altmış"
onlar$(7) = "yetmiş"
onlar$(8) = "seksen"
onlar$(9) = "doksan"

basamak$(1) = ""
basamak$(2) = "bin "
basamak$(3) = "milyon "
basamak$(4) = "milyar "
basamak$(5) = "trilyon "

virgul2 = ""
cevap = ""

'Aşağıdaki 2 satırdaki çift tırnak içerisini değiştirerek
'veya çift tırnağın arasını silerek "" veya "," gibi
'istediğiniz sonucun çıkmasını sağlayabilirsiniz.
YTL = " YTL "
YKR = " YKR "

Say = Str$(sayi#)
virgul = InStr(1, Say, ".")
If virgul Then

'Aşağıdaki satır 26,4 Yirmialtı YTL, kırk YKR olarak okutur.
' (Yirmialtı YTL, DÃ?RT YKR olarak değil)
'iptal etmek isterseniz başyna bir ' tek tırnak işareti koyunuz
If Len(Mid(Say, virgul + 1)) = 1 Then Say = Say + "0"

Say = Right$(Say, Len(Say) - virgul)
GoSub cevir

If cevap = "" Then YKR = ""
virgul2 = cevap + YKR
cevap = ""

Say = Str$(sayi#)
Say = Left$(Say, virgul - 1)
End If
GoSub cevir
If cevap = "" Then YTL = ""
Yaziyla = cevap + YTL + virgul2
Exit Function

cevir:
x = Len(Say)
Say = String$(3 - (x - Int(x / 3) * 3), 48) + Say
x = Len(Say) / 3
For i = 1 To x
uclu = Mid$(Say, Len(Say) - i * 3 + 1, 3)
y = Val(Mid$(uclu, 1, 1))
o = Val(Mid$(uclu, 2, 1))
b = Val(Mid$(uclu, 3, 1))

yazi = ""
If y <> 0 Then
If y > 1 Then yazi = birler$
yazi = yazi + "yüz "
End If

yazi = yazi + onlar$(o) + birler$(b)

If yazi <> "" Then
If LCase(yazi) = "bir" And i = 2 Then yazi = ""
cevap = yazi + basamak$(i) + cevap
End If
Next i
If sayi# < 0 Then cevap = "-Eksi-" + cevap
Return
End Function