Tarihi yazıya dönüştürme

[kurdeng]

Slm Arkadaşlar bana tarihi yazıya dönüştüren bir kod lazım. (01.01.2010--->BİR OCAK İKİBİNON gibi) Elinde olan varsa ve paylaşırsa çok sevinirim, şimdiden teşekürler.

 

[1Al2Ver]

Slm Arkadaşlar bana tarihi yazıya dönüştüren bir kod lazım. (01.01.2010--->BİR OCAK İKİBİNON gibi) Elinde olan varsa ve paylaşırsa çok sevinirim, şimdiden teşekürler.

Kod Modül'e yazılacak ;

Function yaz$(sayi)

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(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

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") Then e$ = "Bin"
s$ = s$ + e$
Next x

If s$ = "" Then s$ = "Sıfır"
If pozitif = 0 Then s$ = "Eksi" + s$

yaz$ = s$
GoTo tamam
hata: yaz$ = "Hata"
tamam:
End Function

A1 = Tarih ( örn ; 16.06.2009 )
B1' e ; =Yaz(GÜN(A1)) & " " & METNEÇEVİR(A1;"aaaa") & " " & Yaz(YIL(A1))

yazınız...

NOT : Sayın Necdet Yeşertener'in çözümünden alıntıdır..

 

[Necdet]

Merhaba,

Kullanıcı tanımlı fonksiyon kullanmak gerek.

A1 Tarih
B1

=BÜYÜKHARF(YAZIYLA(GÜN(A1))&" "&METNEÇEVİR(A1;"AAAA")& " " & YAZIYLA(YIL(A1)))

YAZIYLA fonksiyonu, Yazarı : Kemal PULAT

Function YAZIYLA(Sayi As Variant)
B = Array("", "", "bin", "milyon", "milyar", "trilyon")
Dim A(0 To 2, 0 To 9)
A(0, 0) = ""
A(0, 1) = "yüz"
A(0, 2) = "ikiyüz"
A(0, 3) = "üçyüz"
A(0, 4) = "dörtyüz"
A(0, 5) = "beşyüz"
A(0, 6) = "altıyüz"
A(0, 7) = "yediyüz"
A(0, 8) = "sekizyüz"
A(0, 9) = "dokuzyüz"
 
A(1, 0) = ""
A(1, 1) = "bir"
A(1, 2) = "iki"
A(1, 3) = "üç"
A(1, 4) = "dört"
A(1, 5) = "beş"
A(1, 6) = "altı"
A(1, 7) = "yedi"
A(1, 8) = "sekiz"
A(1, 9) = "dokuz"
 
A(2, 0) = ""
A(2, 1) = "on"
A(2, 2) = "yirmi"
A(2, 3) = "otuz"
A(2, 4) = "kırk"
A(2, 5) = "elli"
A(2, 6) = "altmış"
A(2, 7) = "yetmiş"
A(2, 8) = "seksen"
A(2, 9) = "doksan"
 
Sayi = String(15 - Len(Trim(Int(Sayi))), "0") + Trim(Int(Sayi))
 
Yazi = ""
For i = 1 To Len(Sayi)
    If i Mod 3 = 1 Then
       k = k + 1
       If (Mid(Sayi, Len(Sayi) - i - 1, 3)) <> "000" Then Yazi = B(k) & Yazi
    End If
    Yazi = A(i Mod 3, Val(Mid(Sayi, Len(Sayi) + 1 - i, 1))) & Yazi
Next
If Left(Yazi, 6) = "birbin" Then Yazi = Replace(Yazi, "birbin", "bin")
If Yazi = "" Then Yazi = "sıfır"
YAZIYLA = Yazi
End Function

 

[Zeki Gürsoy]

Örnek:

=Tarih_Cevir(A1)

Function Tarih_Cevir(rng As Range) As String
Dim gg As Byte, aaaa As String, yyyy As Integer

gg = Day(rng)
aaaa = MonthName(Month(rng))
yyyy = Year(rng)

Tarih_Cevir = WorksheetFunction.Proper(Ceviri(gg) & " " & _
            aaaa & " " & _
            Ceviri(yyyy))
End Function

Private Function Ceviri(ByVal Say As String) As String
Dim arr() As Variant, c(1 To 3) As String, tmp As String, s As Byte
    
arr = Array("", "BİR", "İKİ", "ÜÇ", "DÖRT", "BEŞ", "ALTI", "YEDİ", "SEKİZ", "DOKUZ", _
"", "ON", "YİRMİ", "OTUZ", "KIRK", "ELLİ", "ALTMIŞ", "YETMİŞ", "SEKSEN", "DOKSAN", _
"", "YÜZ", "İKİYÜZ", "ÜÇYÜZ", "DÖRTYÜZ", "BEŞYÜZ", "ALTIYÜZ", "YEDİYÜZ", "SEKİZYÜZ", "DOKUZYÜZ", _
"TRİLYON", "MİLYAR", "MİLYON", "BİN", "")
    
Say = String$(15 - Len(Say), "0") + Say
For i = 1 To 15 Step 3
     s = s + 1
     c(1) = Mid$(Say, i, 1)
     c(2) = Mid$(Say, i + 1, 1)
     c(3) = Mid$(Say, i + 2, 1)
     tmp = arr(20 + c(1)) & arr(10 + c(2)) & arr(c(3))
     If tmp <> "" Then tmp = IIf(s = 4 And Trim$(tmp) = "BİR", "BİN", tmp & arr(30 + (s - 1)))
     Ceviri = Ceviri & tmp
Next

Erase arr
Erase c
tmp = Empty
End Function