Tarihi yazı ile yazdırmak

[local1907]

16.08.2009 tarihini "onaltı ağustos ikibindokuz" olarak yazdırabilirmiyiz?

 

[uzmanamele]

merhaba

daha iyisi yapılabilir.
ek dosya işinizi görür mü?

 

[Zeki Gürsoy]

Merhaba,

Boş bir module aşağıdaki fonksiyonları kopyalayın ve sayfada şu formulu uygulayın.

=Tarih_Cevir(H1)

Sonucu: "Bir Ağustos İkibindokuz"

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

 

[uzmanamele]

merhaba

arşivimde bir ktf daha oldu.
teşekkürler Zeki bey

 

[Zeki Gürsoy]

Rica ederim, iyi akşamlar.

 

[halit3]

birtanede benden

=Tarihli(A1)

Function Tarihli(sayi#)
Dim cevap As String
Dim cevap1 As String
Dim yazi As String
Dim yazi1 As String
Dim Say As String
Dim Say1 As String
Dim uclu As String
Dim o As Integer
Dim b As Integer
Dim X As Integer
Dim i As Integer
Dim y As Integer

If sayi# = 0 Then Tarihli = "": Exit Function

ReDim birler$(10), onlar$(10), basamak$(2)

birler$(0) = "": birler$(1) = "bir"
birler$(2) = "iki": 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"

cevap = ""
cevap1 = ""
deger = CDate(sayi#)
yer1 = Mid(deger, 1, 2)
yer2 = Val(Mid(deger, 4, 2))
yer3 = Mid(deger, 7, 4)
Say = Str$(yer1)
Say1 = Str$(yer3)
GoSub cevir
If yer2 = 1 Then
yer2 = "Ocak"
ElseIf yer2 = 2 Then
yer2 = "Şubat"
ElseIf yer2 = 3 Then
yer2 = "Mart"
ElseIf yer2 = 4 Then
yer2 = "Nisan"
ElseIf yer2 = 5 Then
yer2 = "Mayıs"
ElseIf yer2 = 6 Then
yer2 = "Haziran"
ElseIf yer2 = 7 Then
yer2 = "Temmuz"
ElseIf yer2 = 8 Then
yer2 = "Ağustos"
ElseIf yer2 = 9 Then
yer2 = "Eylül"
ElseIf yer2 = 10 Then
yer2 = "Ekim"
ElseIf yer2 = 11 Then
yer2 = "Kasım"
ElseIf yer2 = 12 Then
yer2 = "Aralık"
Else
yer2 = "Tarih yanlış"
End If
ker = Len(cevap)
ker1 = UCase(Mid(cevap, 1, 1))
If ker1 = "I" Then
ker1 = "İ"
End If
ker2 = Mid(cevap, 2, ker)
cevap = ker1 & ker2
ker3 = Len(cevap1)
ker4 = UCase(Mid(cevap1, 1, 1))
If ker4 = "I" Then
ker4 = "İ"
End If
ker5 = Mid(cevap1, 2, ker3)
cevap1 = ker4 & ker5
Tarihli = cevap & " " & yer2 & " " & cevap1

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
X = Len(Say1)
Say1 = String$(3 - (X - Int(X / 3) * 3), 48) + Say1
X = Len(Say1) / 3
For i = 1 To X
uclu = Mid$(Say1, Len(Say1) - i * 3 + 1, 3)
y = Val(Mid$(uclu, 1, 1))
o = Val(Mid$(uclu, 2, 1))
b = Val(Mid$(uclu, 3, 1))
yazi1 = ""
If y <> 0 Then
If y > 1 Then yazi1 = birler$
yazi1 = yazi1 + "yüz"
End If
yazi1 = yazi1 + onlar$(o) + birler$(b)
If yazi1 <> "" Then
If LCase(yazi1) = "bir" And i = 2 Then yazi1 = ""
cevap1 = yazi1 + basamak$(i) + cevap1
End If
Next i
Return
End Function