Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 12-10-2017, 21:35   #1
kemal turan
Altın Üye
 
Giriş: 10/06/2011
Şehir: Adana
Mesaj: 1,208
Excel Vers. ve Dili:
Excel 2016
Varsayılan Sayıyı yazıya çevirme kod hatası

Merhaba,
Aşağıdaki kod sayıyı yazıya çevir kodudur. Forumdan aldım.
4 rakamlı binler sayısının başına "bir" yazsını fazla ekliyor.
Örnek: 1112 rakamını "Bir Bin Yüz On İki LİRA" olarak yazıyor.
Düzeltemedim.
Yardımınızı rica ediyorum
Teşekkürler

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Function YAZIYAÇEVİR(Para, Optional PBirim = "LİRA", Optional KBirim = "KURUŞ")
    Dim ParaStr As String
    Dim Lira As String, Kuruş As String
    
    If Not IsNumeric(Para) Then
    YAZIYAÇEVİR = "#DEĞER!"
    Exit Function
    End If
    
    ParaStr = Format(Abs(Para), "0.00")
    
    Lira = Left(ParaStr, Len(ParaStr) - 3)
    Kuruş = Right(ParaStr, 2)
    
    YAZIYAÇEVİR = IIf(Para < 0, "Eksi ", "") & ÇEVİR(Lira) & " " & PBirim & " " & _
                  IIf(Val(Kuruş) <> 0, ÇEVİR(Kuruş) & " " & KBirim & " ", "")
End Function

Private Function ÇEVİR(SayıStr As String) As String
    Dim Rakam(15)
    Dim C(3), Sonuç, E
    
    Birler = Array("", " Bir ", " İki ", " Üç ", " 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 ", "")
    
    SayıStr = String(15 - Len(SayıStr), "0") + SayıStr
    
    For i = 1 To 15
    Rakam(i) = Val(Mid$(SayıStr, i, 1))
    Next i
    
    Sonuç = ""
    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 = "Bir ") Then E = "Bin"
    Sonuç = Sonuç + E
    Next i
    
    If Sonuç = "" Then Sonuç = "Sıfır"
    
    ÇEVİR = UCase(Mid(Sonuç, 1, 1)) + Mid(Sonuç, 2, Len(Sonuç) - 1)
End Function
__________________
Hayat; yaşamayı,
Mutluluk; gülümsemeyi,
Sevgi; Haketmeyi,
Vefa; hatırlamayı,
Dostluk;paylaşmayı bilen için vardır..
----------------------------------
kemal turan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-10-2017, 21:37   #2
Necdet Yeşertener
Moderatör
 
Giriş: 04/06/2005
Şehir: Ankara
Mesaj: 11,870
Excel Vers. ve Dili:
Ofis 2003 İngilizce Ofis 2007 Türkçe Ofis 2010 Türkçe
Varsayılan

Merhaba,

Forumda başka fonksiyon bulunuz. Doğru çalışan fonksiyonlar var.
__________________
Sayfada Boş Satırları Silmek:
Sütunu Seçiniz, F5, Özel, Boşluklar, Tamam,
Sağ Klik, Sil, Tüm Satır, Tamam

Türkçe'nin Bir Eksiği Yok, Ya Sizin?



Necdet Yeşertener Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-10-2017, 22:22   #3
kemal turan
Altın Üye
 
Giriş: 10/06/2011
Şehir: Adana
Mesaj: 1,208
Excel Vers. ve Dili:
Excel 2016
Varsayılan

Merhaba Necdet Hocam,
Bulduğum kodların hepsinde aynı hata var.
doğru link hususunda yardımcı olursanız sevinirim.
__________________
Hayat; yaşamayı,
Mutluluk; gülümsemeyi,
Sevgi; Haketmeyi,
Vefa; hatırlamayı,
Dostluk;paylaşmayı bilen için vardır..
----------------------------------
kemal turan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-10-2017, 22:41   #4
kemal turan
Altın Üye
 
Giriş: 10/06/2011
Şehir: Adana
Mesaj: 1,208
Excel Vers. ve Dili:
Excel 2016
Varsayılan

merhaba,
Aşağıdaki kodu bir modüle alarak uyguladım, sorunsuz çalışıyor.
Teşekkür ederim.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Public Function YaziylaTL(cTutar As Currency) As String
Dim cLira As Currency, cKurus As Currency, sStr As String, bEksi As Boolean
If cTutar < 0 Then cTutar = -cTutar: bEksi = True
cTutar = Format(cTutar, "#,##0.00")
cLira = Int(cTutar)
cKurus = Left((cTutar - cLira) * 100, 2)
If cLira = 0 Then
sStr = ""
Else
sStr = Yaziyla(cLira) & " TL"
End If
If cKurus = 0 Then
sStr = sStr & ""
Else
sStr = sStr & IIf(sStr <> "", ", ", "") & Yaziyla(cKurus) & " KR"
End If
If sStr = "" Then sStr = "sıfır"
If bEksi Then sStr = "eksi" & sStr
YaziylaTL = sStr
End Function

Private Function Yaziyla(cTutar As Currency)
Dim a, s, e As String
Dim pozitif, negatif As Boolean
Dim X As Byte
Dim b$(9)
Dim Y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)

b$(0) = ""
b$(1) = "Bir"
b$(2) = "İki"
b$(3) = "Üç"
b$(4) = "Dört"
b$(5) = "Beş"
b$(6) = "Altı"
b$(7) = "Yedi"
b$(8) = "Sekiz"
b$(9) = "Dokuz"

Y$(0) = ""
Y$(1) = "On"
Y$(2) = "Yirmi"
Y$(3) = "Otuz"
Y$(4) = "Kırk"
Y$(5) = "Elli"
Y$(6) = "Altmış"
Y$(7) = "Yetmiş"
Y$(8) = "Seksen"
Y$(9) = "Doksan"

m$(0) = "Trilyon"
m$(1) = "Milyar"
m$(2) = "Milyon"
m$(3) = "Bin"
m$(4) = ""

a = Str(cTutar)
If Left$(a, 1) = " " Then pozitif = 1 Else pozitif = 0
a = Right$(a, Len(a) - 1)
For X = 1 To Len(a)
If (Asc(Mid$(a, X, 1)) > Asc("9")) Or (Asc(Mid$(a, X, 1)) < Asc("0")) Then GoTo hata
Next X
If Len(a) > 15 Then GoTo hata
a = String(15 - Len(a), "0") + a
For X = 1 To 15
v(X) = Val(Mid$(a, X, 1))
Next X
s = ""
For X = 0 To 4
c(1) = v((X * 3) + 1)
c(2) = v((X * 3) + 2)
c(3) = v((X * 3) + 3)
If c(1) = 0 Then
e = ""
ElseIf c(1) = 1 Then
e = "Yüz"
Else
e = b$(c(1)) + "Yüz"
End If
e = e + Y$(c(2)) + b$(c(3))
If e <> "" Then e = e + m$(X)
If (X = 3) And (e = "birbin" Or e = "BirBin") Then e = "Bin"
s = s + e
Next X
If s = "" Then s = "sıfır"
If pozitif = 0 Then s = "eksi" + s
Yaziyla = s '+ " TL"
GoTo tamam
hata: Yaziyla = "HATA"
tamam:
End Function
__________________
Hayat; yaşamayı,
Mutluluk; gülümsemeyi,
Sevgi; Haketmeyi,
Vefa; hatırlamayı,
Dostluk;paylaşmayı bilen için vardır..
----------------------------------
kemal turan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-10-2017, 23:35   #5
byfika
Altın Üye
 
Giriş: 15/08/2009
Şehir: İZMİR
Mesaj: 10
Excel Vers. ve Dili:
2003
Varsayılan

Merhabalar, istediğiniz kodlu örnek ektedir. Açıklama sayfa1 de
Deneyiniz. İyi günler
Eklenmiş Dosyalar
Dosya Türü: xlsm rakamı yazıya çevirme.xlsm (19.4 KB, 10 Görüntülenme)
byfika Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-10-2017, 11:21   #6
kemal turan
Altın Üye
 
Giriş: 10/06/2011
Şehir: Adana
Mesaj: 1,208
Excel Vers. ve Dili:
Excel 2016
Varsayılan

Sn.Byfika
Geç cevap için özür dilerim.
Çok teşekkür ederim.
Selametle kalınız.
__________________
Hayat; yaşamayı,
Mutluluk; gülümsemeyi,
Sevgi; Haketmeyi,
Vefa; hatırlamayı,
Dostluk;paylaşmayı bilen için vardır..
----------------------------------
kemal turan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-10-2017, 16:41   #7
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,417
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Alternatif linkler

http://www.excel.web.tr/f48/rakamy-y...e-t110954.html
http://www.excel.web.tr/f48/yazyyla-...ar-t67961.html
http://www.excel.web.tr/f14/sayyyy-y...sy-t99803.html
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 17:53


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden