-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
sayıyı yazıya çevirme hk.
- Konbuyu başlatan selim zan
- Başlangıç tarihi
yzıyla ytl
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) = "İki": 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ÃIDAKİ 2 SATIRDAKİ ÇİFT TIRNAK İÇERİÃİNİ DEÃİÃTİREREK
'VEYA ÇİFT TIRNAÃIN ARASINI SİLEREK "" VEYA "," GİBİ
'İSTEÃİNİZ SONUCUN ÇIKMASINI SAÃLAYABİLİRSİNİZ.
YTL = " YTL , "
YKR = " YKR "
Say = Str$(Sayi#)
virgul = InStr(1, Say, ".")
If virgul Then
'Aşağadaki satır 26,4 Yirmialtı YTL, KIRK YKR olarak okutur.
' (Yirmialtı YTL, DÃ?RT YKR olarak değil)
'İptal etmek isterseniz başına 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
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) = "İki": 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ÃIDAKİ 2 SATIRDAKİ ÇİFT TIRNAK İÇERİÃİNİ DEÃİÃTİREREK
'VEYA ÇİFT TIRNAÃIN ARASINI SİLEREK "" VEYA "," GİBİ
'İSTEÃİNİZ SONUCUN ÇIKMASINI SAÃLAYABİLİRSİNİZ.
YTL = " YTL , "
YKR = " YKR "
Say = Str$(Sayi#)
virgul = InStr(1, Say, ".")
If virgul Then
'Aşağadaki satır 26,4 Yirmialtı YTL, KIRK YKR olarak okutur.
' (Yirmialtı YTL, DÃ?RT YKR olarak değil)
'İptal etmek isterseniz başına 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
Sayın Leventm tarafından oluşturulmuş aşağıda yazılı fonksiyonu bilgisayarıma eklenti olarak yükledim. Bütün dosyalarda kullanıyorum,biç bir sorun yok.
A1 Hücresinde YTL B1 Hücresinde YKR var ise eğer C1 hücresine yazı ile yazdırmak istersen C1 hücresine =Yaz(A1;B1) yazıyorsun.
Function yaz$(ytl, ykr)
Dim aa(2)
Dim deg(2)
aa(1) = ytl
aa(2) = ykr
For zz = 1 To 2
sayi = aa(zz)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v$(15)
Dim c$(3)
b$(0) = ""
b$(1) = "BİR"
b$(2) = "İKİ"
b$(3) = "ÜÇ"
b$(4) = "DÃ?RT"
b$(5) = "BEÃ"
b$(6) = "ALTI"
b$(7) = "YEDİ"
b$(8) = "SEKİZ"
b$(9) = "DOKUZ"
y$(0) = ""
y$(1) = "ON"
y$(2) = "YİRMİ"
y$(3) = "OTUZ"
y$(4) = "KIRK"
y$(5) = "ELLİ"
y$(6) = "ALTMIÃ"
y$(7) = "YETMİÃ"
y$(8) = "SEKSEN"
y$(9) = "DOKSAN"
m$(0) = "TRILYON"
m$(1) = "MİLYAR"
m$(2) = "MİLYON"
m$(3) = "BİN"
m$(4) = ""
a$ = Str(sayi)
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
a$ = ""
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$ = "BİRBİN") Then e$ = "BİN"
s$ = s$ + e$
Next x
If s$ = "" Then s$ = "SIFIR"
If pozitif = 0 Then s$ = "" + s$
deg(zz) = s$
GoTo tamam
hata: yaz$ = "hata"
tamam:
s$ = ""
Next
yaz$ = deg(1) & " YTL " & deg(2) & " YKR"
End Function
A1 Hücresinde YTL B1 Hücresinde YKR var ise eğer C1 hücresine yazı ile yazdırmak istersen C1 hücresine =Yaz(A1;B1) yazıyorsun.
Function yaz$(ytl, ykr)
Dim aa(2)
Dim deg(2)
aa(1) = ytl
aa(2) = ykr
For zz = 1 To 2
sayi = aa(zz)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v$(15)
Dim c$(3)
b$(0) = ""
b$(1) = "BİR"
b$(2) = "İKİ"
b$(3) = "ÜÇ"
b$(4) = "DÃ?RT"
b$(5) = "BEÃ"
b$(6) = "ALTI"
b$(7) = "YEDİ"
b$(8) = "SEKİZ"
b$(9) = "DOKUZ"
y$(0) = ""
y$(1) = "ON"
y$(2) = "YİRMİ"
y$(3) = "OTUZ"
y$(4) = "KIRK"
y$(5) = "ELLİ"
y$(6) = "ALTMIÃ"
y$(7) = "YETMİÃ"
y$(8) = "SEKSEN"
y$(9) = "DOKSAN"
m$(0) = "TRILYON"
m$(1) = "MİLYAR"
m$(2) = "MİLYON"
m$(3) = "BİN"
m$(4) = ""
a$ = Str(sayi)
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
a$ = ""
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$ = "BİRBİN") Then e$ = "BİN"
s$ = s$ + e$
Next x
If s$ = "" Then s$ = "SIFIR"
If pozitif = 0 Then s$ = "" + s$
deg(zz) = s$
GoTo tamam
hata: yaz$ = "hata"
tamam:
s$ = ""
Next
yaz$ = deg(1) & " YTL " & deg(2) & " YKR"
End Function
- Katılım
- 13 Ekim 2004
- Mesajlar
- 16,060
- Excel Vers. ve Dili
- Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
Sn otufan03
Bir düzeltme yapmak istiyorum. Yazdığınız kod bana ait değildir.
Sn feza2
Bu konuda yeni iseniz, nereden başlayacağınızı ve ne soracağınızı bilmiyorsanız şimdilik forumu sadece takip edin. Excel'e yeni Başlayanlar bölümü başta olmak üzere sorulan soruları ve gelen cevapları okuyun. Excel'de Bunları Biliyormuydunuz ve Excel Dersanesi gibi bölümlerini inceleyin. Zamanla soru soracak veya gelen sorulara cevap verecek duruma gelirsiniz.
Bu konuda yeni iseniz, nereden başlayacağınızı ve ne soracağınızı bilmiyorsanız şimdilik forumu sadece takip edin. Excel'e yeni Başlayanlar bölümü başta olmak üzere sorulan soruları ve gelen cevapları okuyun. Excel'de Bunları Biliyormuydunuz ve Excel Dersanesi gibi bölümlerini inceleyin. Zamanla soru soracak veya gelen sorulara cevap verecek duruma gelirsiniz.