rakamları yazı ile yazdırma (istek)

[Emine Şahin]

merhaba arkadaşlar. forumda konu ile ilgili bilgi mevcut idi. lakin 2007 kullanmamdan mı kaynaklanıyor bilemiyorum ama eklentiyi çalıştıramadım.
istediğim sadece ekteki dosyada kırmızı dolgu verdiğim (dolgunun bir özelliği yok, sadece yerini belirtmek için) hücreye bir üstteki hücrenin değerlerinin yazı olarak yazmasını istiyorum. mümkün mü?

 

[ersoyalan]

ekte dosya yok.

 

[Emine Şahin]

dosya eklemede hata alıyorum. resim olarak ekledim.
tekrar farklı kaydetten 2003 olarak kaydettim.
dosya ektedir.
teşekkür...

 

[ersoyalan]

Merhaba,

=YTL(G39)

G40 hücresine formülünü yapıştırın.

E.ALAN

 

[Emine Şahin]

denedim ama hata veriyor. geçersiz ad hatası diyor.

 

[ersoyalan]

Merhaba,

Dosyanız ektedir.

E.ALAN

 

[Emine Şahin]

Merhaba,

Dosyanız ektedir.

E.ALAN

merhaba ersoy bey. ama ekteki resimdeki gibi hatalı.
çalışmadı bende ama.

 

[ersoyalan]

Merhaba,

Eklentiyi gönderiyorum.

=YAZIYLA(F39) formülü yapıştırdığınız zaman olması gerekli.

E.ALAN

 

[usum_ay]

TL ile

rakamları yazı ile yazarken .......TL .....KRŞ şeklindeki versiyonunu alabilir miyiz?

 

[rasim535]

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 TL As String
Dim Kr As String

If Sayi# = 0 Then Yaziyla = "SIFIR": Exit Function

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

birler$(0) = "": birler$(1) = "BİR"
birler$(2) = "İKİ": birler$(3) = "ÜÇ"
birler$(4) = "DÖRT": birler$(5) = "BEŞ"
birler$(6) = "ALTI": birler$(7) = "YEDİ"
birler$(8) = "SEKİZ": birler$(9) = "DOKUZ"

onlar$(0) = "": onlar$(1) = "ON"
onlar$(2) = "YİRMİ": onlar$(3) = "OTUZ"
onlar$(4) = "KIRK": onlar$(5) = "ELLİ"
onlar$(6) = "ALTMIŞ": onlar$(7) = "YETMİŞ"
onlar$(8) = "SEKSEN": onlar$(9) = "DOKSAN"

BASAMAK$(1) = "": BASAMAK$(2) = "BİN "
BASAMAK$(3) = "MİLYON ": BASAMAK$(4) = "MİLYAR "
BASAMAK$(5) = "TRİLYON "

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.
TL = ".-TL., "
Kr = ".-Kr."

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

'Aşağadaki satır 26,4 Yirmialtı TL, KIRK Kr olarak okutur.
' (Yirmialtı TL, DÖRT Kr 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 Kr = ""
virgul2 = cevap + Kr
cevap = ""

Say = Str$(Sayi#)
Say = Left$(Say, virgul - 1)
End If
GoSub cevir
If cevap = "" Then TL = ""
Yaziyla = cevap + TL + 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) = "BİR" And i = 2 Then yazi = ""
If yazi = "BİR" And BASAMAK$(i) = "BİN " Then
cevap = BASAMAK$(i) + cevap
Else
cevap = yazi + BASAMAK$(i) + cevap
End If
End If
Next i
If Sayi# < 0 Then cevap = "-Eksi-" + cevap
Return
End Function