DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Formulle cok zor. Hazir makro kodlari var bunun icin. Alttaki videonun aciklamalar kisminda indirme linki var.
Bulamadım hocam
Function Sayıyı_Yazıya_Çevir(Tutar As Currency) As String
Function SayiyiYaziyaCevir(Tutar As Currency) As String
Dim BuyukDeger As Variant
Dim Bolumler As Variant
Dim i As Integer
Dim BolumSayisi As Integer
BuyukDeger = Array("", " bin ", " milyon ", " milyar ", " trilyon ", " katrilyon ")
Tutar = Int(Tutar)
If Tutar = 0 Then
SayiyiYaziyaCevir = "sıfır"
Exit Function
End If
Bolumler = Split(Format(Tutar, "#"), "")
BolumSayisi = UBound(Bolumler) + 1
For i = 0 To BolumSayisi - 1
If Val(Bolumler(i)) <> 0 Then
SayiyiYaziyaCevir = SayiyiYaziyaCevir & UcBasamakYazi(Val(Bolumler(i))) & BuyukDeger(BolumSayisi - i - 1)
End If
Next i
SayiyiYaziyaCevir = Application.WorksheetFunction.Proper(Trim(SayiyiYaziyaCevir))
If Left(SayiyiYaziyaCevir, 7) = "Bir Bin" Then
SayiyiYaziyaCevir = Replace(SayiyiYaziyaCevir, "Bir Bin", "Bin")
End If
End Function
Function UcBasamakYazi(Sayi As Integer) As String
Dim Birler As Variant, Onlar As Variant
Dim Yuzler As String, OnlarBirler As String
Birler = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
Onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
Yuzler = IIf(Sayi \ 100 = 1, "yüz", IIf(Sayi \ 100 > 1, Birler(Sayi \ 100) & " yüz", ""))
OnlarBirler = Onlar((Sayi Mod 100) \ 10) & " " & Birler(Sayi Mod 10)
UcBasamakYazi = Trim(Yuzler & " " & OnlarBirler)
End Function
Ben şu sayıları yazdım değer hatası veriyor. 1001 , 10056 , 1005145 vb.
Function SayiyiYaziyaCevir(Sayi As Double) As String
Dim Birler() As String
Dim Onlar() As String
Dim Yuzler() As String
Dim Result As String
Dim basamak As Integer
Dim On, Yuz As Integer
Birler = Split("Bir,İki,Üç,Dört,Beş,Altı,Yedi,Sekiz,Dokuz", ",")
Onlar = Split("On,Yirmi,Otuz,Kırk,Elli,Altmış,Yetmiş,Seksen,Doksan", ",")
Yuzler = Split("Yüz,İki Yüz,Üç Yüz,Dört Yüz,Beş Yüz,Altı Yüz,Yedi Yüz,Sekiz Yüz,Dokuz Yüz", ",")
If Sayi = 0 Then
SayiyiYaziyaCevir = "Sıfır"
Exit Function
End If
basamak = 0
Result = ""
Yuz = Int(Sayi / 100)
If Yuz > 0 Then
Result = Result & Yuzler(Yuz - 1) & " "
Sayi = Sayi - (Yuz * 100)
End If
On = Int(Sayi / 10)
If On > 0 Then
Result = Result & Onlar(On - 1) & " "
Sayi = Sayi - (On * 10)
End If
If Sayi > 0 Then
Result = Result & Birler(Sayi - 1)
End If
SayiyiYaziyaCevir = Application.Trim(Result)
End Function=SayiyiYaziyaCevir(B19)Teşekkür ederim oldu
Bu kod ondalık sayıları çevirmiyor örnek 101,52
Function Yaziyla(sayi#)
Dim virgul2 As String, cevap As String, yazi As String, say As String, uclu As String
Dim virgul1 As Integer, o As Integer, b As Integer, X As Integer, i As Integer, y As Integer
Dim TL As String, KR As String
If sayi# = 0 Then Yaziyla = "": Exit Function
virgul2 = "": cevap = "": TL = ".TL.": KR = ".Krş."
ReDim Birler$(10), Onlar$(10), basamak$(6)
Birler$(0) = "": Onlar$(0) = "": basamak$(1) = "":
Birler$(1) = "bir": Onlar$(1) = "on": basamak$(2) = "bin"
Birler$(2) = "iki": Onlar$(2) = "yirmi": basamak$(3) = "milyon":
Birler$(3) = "üç": Onlar$(3) = "otuz": basamak$(4) = "milyar"
Birler$(4) = "dört": Onlar$(4) = "kırk": basamak$(5) = "trilyon"
Birler$(5) = "beş": Onlar$(5) = "elli": basamak$(6) = "katrilyon"
Birler$(6) = "altı": Onlar$(6) = "altmış":
Birler$(7) = "yedi": Onlar$(7) = "yetmiş"
Birler$(8) = "sekiz": Onlar$(8) = "seksen":
Birler$(9) = "dokuz": Onlar$(9) = "doksan"
say = Str$(sayi#)
virgul1 = InStr(1, say, ".")
If virgul1 Then
If Len(Mid(say, virgul1 + 1)) = 1 Then say = say + "0"
say = Right$(say, Len(say) - virgul1)
GoSub cevir
If cevap = "" Then KR = ""
virgul2 = cevap + KR
cevap = ""
say = Left$(Str$(sayi#), virgul1 - 1)
End If
GoSub cevir
If cevap = "" Then TL = ""
Yaziyla = WorksheetFunction.Proper(cevap) + TL + WorksheetFunction.Proper(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$(y)
yazi = yazi + "yüz"
End If
yazi = yazi + Onlar$(o) + Birler$(b)
If yazi <> "" Then
If yazi = "bir" And i = 2 Then yazi = ""
cevap = yazi + basamak$(i) + cevap
End If
Next i
If sayi# < 0 Then
cevap = "-Eksi-" + WorksheetFunction.Proper(cevap)
End If
Return
End FunctionHocam eline emeğine sağlık Çok teşekkür ederim tek sıkıntı Altıbin dokuzyüzyirmiüç
Kod 2016 da çalışıyor
Sayılar hücreye sığmamış hücreyi (sütun) birazcık açarsanız orada görünmeyen ondalık sayılar var.
Function yaziyacevir(rakam)
Dim grup(5), sayi(10, 3), basamak(5), oku(3)
sayi(0, 1) = "": sayi(0, 2) = "": sayi(0, 3) = ""
sayi(1, 1) = "YÜZ": sayi(1, 2) = "ON": sayi(1, 3) = "BİR"
sayi(2, 1) = "İKİYÜZ": sayi(2, 2) = "YİRMİ": sayi(2, 3) = "İKİ"
sayi(3, 1) = "ÜÇYÜZ": sayi(3, 2) = "OTUZ": sayi(3, 3) = "ÜÇ"
sayi(4, 1) = "DÖRTYÜZ": sayi(4, 2) = "KIRK": sayi(4, 3) = "DÖRT"
sayi(5, 1) = "BEŞYÜZ": sayi(5, 2) = "ELLİ": sayi(5, 3) = "BEŞ"
sayi(6, 1) = "ALTIYÜZ": sayi(6, 2) = "ALTMIŞ": sayi(6, 3) = "ALTI"
sayi(7, 1) = "YEDİYÜZ": sayi(7, 2) = "YETMİŞ": sayi(7, 3) = "YEDİ"
sayi(8, 1) = "SEKİZYÜZ": sayi(8, 2) = "SEKSEN": sayi(8, 3) = "SEKİZ"
sayi(9, 1) = "DOKUZYÜZ": sayi(9, 2) = "DOKSAN": sayi(9, 3) = "DOKUZ"
basamak(5) = "TRİLYON"
basamak(4) = "MİLYAR"
basamak(3) = "MİLYON"
basamak(2) = "BİN"
basamak(1) = ""
lira = Int(rakam)
kurus = Round(rakam - lira, 2) * 100
If Len(lira) > 15 Then
MsgBox ("Bu fonksiyon en fazla 15 haneli sayılar için çalışır.")
End
End If
kalan = lira
yaziyacevir = ""
For x = 1 To 5
a = 15 - 3 * x
If Len(lira) > a Then
grup(6 - x) = Int(kalan / 10 ^ a)
kalan = kalan - (grup(6 - x) * 10 ^ a)
End If
Next x
If grup(5) > 0 Then
oku(1) = Int(grup(5) / 100)
baskalan = grup(5) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(5)
End If
If grup(4) > 0 Then
oku(1) = Int(grup(4) / 100)
baskalan = grup(4) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(4)
End If
If grup(3) > 0 Then
oku(1) = Int(grup(3) / 100)
baskalan = grup(3) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(3)
End If
If grup(2) = 1 Then
yaziyacevir = yaziyacevir + "BİN"
End If
If grup(2) > 1 Then
oku(1) = Int(grup(2) / 100)
baskalan = grup(2) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(2)
End If
If grup(1) > 0 Then
oku(1) = Int(grup(1) / 100)
baskalan = grup(1) - oku(1) * 100
oku(2) = Int(baskalan / 10)
oku(3) = baskalan - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(1)
End If
yaziyacevir = yaziyacevir + " TL."
If kurus > 0 Then
oku(2) = 0
If Len(kurus) > 1 Then
oku(2) = Int(kurus / 10)
End If
oku(3) = kurus - oku(2) * 10
yaziyacevir = yaziyacevir + sayi(oku(2), 2) + sayi(oku(3), 3) + " KR."
End If
End Function