Yazıyla_Rakam Fonksiyonuna Dizi ilave etme

[hsayar]

Merhaba Arkadaşlar Rakamı hücreye yazmak için aşağıdaki fonksiyonu kullanıyorum.ama Şimdi değişik bir hali lazım oldu Basamakta yer alan her kelimeyi diznin her elmanına ayrı atamak hususunda yardımlarınız bekliyoreum
Dizmiz YazOku() olsun
1 için YazOku(1) = "Bir"
11 için YazOku(1) = "On"
YazOku(2) = "Bir"
111 için YazOku(1) = "Yüz"
YazOku(2) = "On"
YazOku(3) = "Bir"
vs.... şeklinde yapabilirmiyiz.

Function Yazıyla_Rakam(Sayı, Optional TBirim = "YTL", Optional ABirim = "YKR", _
                             Optional OnUzun = 2, Optional OnSis As Boolean = False)
'###################################################################################################
'#########                        Bir rakamı yazı ile yazar.                               #########
'#########                 İster para, ister metre veya  ondalık sistemde                  #########
'#########                 yazabilmeniz için yeniden düzenlenmiştir.                       #########
'#########                             Hsayar - 03/03/2008                                 #########
'###################################################################################################
'Sayı               : Bir Sayı Giriniz
'TBirim             : Virgülden önceki  kısmın Ölçü cinsi (Ytl, Kg, Metre... vs)
'ABirim             : Virgülden sonraki kısmın Ölçü cinsi (Ykr, g, cm... vs)
'OnUzun             : Virgülden sonra dikkate alınacak rakam sayısı _
                      (Paralar için = 2, kilolar için = 3 vs...)
'OnSis              : Eğer Onluk sistemdeki gibi yazacaksanız "True" veya 1 _
                      mesala 15,25 = "Onbeş tam yüzde yirmibeş" gibi.
    Dim ParaStr$, OnFrm$, Lira$, Kurus$
    Dim ArrOran() As Variant
    Dim i&
    
    If Not IsNumeric(Sayı) Then
        Yazıyla_Rakam = "GİRİLEN DEĞER SAYI DEĞİL!"
        Exit Function
    End If

    OnFrm = "0."
    For i = 1 To OnUzun:        OnFrm = OnFrm & "0":    Next i
    ParaStr = Format(Abs(Sayı), OnFrm)
    
    Lira = Left(ParaStr, Len(ParaStr) - (OnUzun + 1)):     Kurus = Right(ParaStr, OnUzun)
    If OnSis = True Then
        ArrOran = Array("", ", Onda ", ", Yüzde ", ", Binde ", _
                        ", Onbinde ", ", Yüzbinde ", ", Milyonda ", _
                        ", OnMilyonda ", ", YüzMilyonda ", ", Milyarda ", _
                        ", OnMilyarda ", ", YüzMilyarda ", ", Trilyonda ", _
                        ", OnTrilyonda ", ", YüzTrilyonda ")
        TBirim = "Tam"
        If Val(Kurus) <> 0 Then TBirim = TBirim & ArrOran(OnUzun)
        ABirim = ""
        Erase ArrOran
    End If
    
    Yaz&#305;yla_Rakam = IIf(Say&#305; < 0, "Eksi ", "") & cevir(Lira) & " " & TBirim & " " & _
                    IIf(Val(Kurus) <> 0, cevir(Kurus) & " " & ABirim & " ", "")

ParaStr = "": OnFrm = "": Lira = "": Kurus = "": i = 0
Erase ArrOran()
End Function
Private Function cevir(SayiStr As String) As String
    Dim Rakam(15) As Variant, c(3) As Variant
    Dim Birler()  As Variant, onlar() As Variant, Binler()  As Variant
    Dim Sonuc$, e$, i&
    
    Birler = Array("", "bir", "iki", "&#252;&#231;", "d&#246;rt", "be&#351;", "alt&#305;", "yedi", "sekiz", "dokuz")
    onlar = Array("", "on", "yirmi", "otuz", "k&#305;rk", "elli", "altm&#305;&#351;", "yetmi&#351;", "seksen", "doksan")
    Binler = Array("trilyon", "milyar", "milyon", "bin", "")
    
    SayiStr = String(15 - Len(SayiStr), "0") + SayiStr
    
    For i = 1 To 15
      Rakam(i) = Val(Mid$(SayiStr, i, 1))
    Next i
    
    Sonuc = ""
    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&#252;z"
      Else
        e = Birler(c(1)) + "y&#252;z"
      End If
      e = e + onlar(c(2)) + Birler(c(3))
      If e <> "" Then e = e + Binler(i)
      If (i = 3) And (e = "birbin") Then e = "bin"
      Sonuc = Sonuc + e
    Next i

    If Sonuc = "" Then Sonuc = "00"
    cevir = UpperTr(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1)
    Erase Rakam():          Erase c()
    Erase Birler():         Erase onlar():     Erase Binler()
    Sonuc = "": e = "": i = 0
End Function

 

[hsayar]

Günaydın
Güncel Yardım edebi,lirserniz sevinirim.

 

[hsayar]

Günaydın
Güncel Yardım edebi,lirserniz sevinirim.

 

[veyselemre]

Yanlış anlamadıysam aşağıdaki fonksiyon işinizi görür.

Function basamakDegeri(Sayi As Double, bas As Byte) As String
    say = Trim(Sayi)
    uz = Len(say)
    If bas > uz Or uz > 15 Then
        basamakDegeri = "HATA"
        Exit Function
    End If
    bul = Val(Mid(say, bas, 1) & String(Len(say) - bas, "0"))
    uz = Len(bul)
    If Val(bul) = 0 Then
        basamakDegeri = "sıfır"
    Else
        birler = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
        onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
        binler = Array("", "bin", "milyon", "milyar", "trilyon")

        grupIci = uz Mod 3
        If uz Mod 3 = 0 Then binlerGrup = (uz \ 3) - 1 Else binlerGrup = (uz \ 3)

        bak = Left(bul, 1)
        Select Case grupIci
            Case 1
                basamakDegeri = birler(bak)
            Case 2
                basamakDegeri = onlar(bak)
            Case 0
                If bak > 1 Then basamakDegeri = birler(bak) & "yüz" Else basamakDegeri = "yüz"
        End Select
        basamakDegeri = Replace(basamakDegeri & binler(binlerGrup), "birbin", "bin")
    End If
End Function

Sub dene()
Dim sayis As Double
Dim sira As Byte
    For x = 1 To 15
        sayis = Val(sayis & 1)
        sira = 1
        MsgBox Format(sayis, "0,000") & vbCr & sira & vbCr & vbCr & basamakDegeri(sayis, sira)
    Next
End Sub

 

[hsayar]

veysel hocam alakanıza teşekkür ederim istediğimi herhalde ben tam anlatamıdım sizin dene prosodürünüz üzerinde izah edeyim

Sub dene()
Dim sayis, tamsayı As Double
Dim sira As Byte
    sayis = 123456789012345#
    tamsayı = Str(Int(sayis))
    uz = Len(tamsayı) - 1
    For x = 1 To uz
    sira = x
        MsgBox basamakDegeri(tamsayı, sira)
    Next
End Sub

sayis = 123456789012345# değeri için sıra ile dönecek değerler
yüz
yirmi
üç
trilyon
dört
yüz
elli
altı
milyar
yedi
yüz
seksen
dokuz
milyon
on
iki
bin
üç
yüz
kırk
beş
şeklinde olmalıdır.
tekrar yardım edebilirseniz sevinirim.

 

[veyselemre]

Fonksiyon, sonucu istediğiniz gibi diziye aktarır.

Function yaziyaCevirParcala(Sayi As Double) As Variant
Dim m As Byte
    say = Trim(Sayi)
    uz = Len(say)

    If uz > 15 Then
        yaziyaCevirParcala = "HATA"
        Exit Function
    End If

    If Val(say) = 0 Then
        yaziyaCevirParcala = Array("sıfır")
        Exit Function
    End If

    birler = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
    onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
    binler = Array("", "bin", "milyon", "milyar", "trilyon")
    arrChr = "|"
    say = String(15 - Len(say), "0") & say
    m = 5
    For x = 1 To 13 Step 3
            ekle1 = "": ekle2 = "": ekle3 = ""
            m = m - 1
            parca = Mid(say, x, 3)
            If Val(parca) > 0 Then
                If Val(parca) = 1 And m = 1 Then
                    birles = "bin" & arrChr
                Else
                    al = Val(Mid(parca, 1, 1))
                    If al > 0 Then
                        ekle1 = "yüz" & arrChr
                        If al > 1 Then ekle1 = birler(al) & arrChr & ekle1
                    End If
                    al = Val(Mid(parca, 2, 1)): If al > 0 Then ekle2 = onlar(al) & arrChr

                    al = Val(Mid(parca, 3, 1))
                    If al > 0 Then ekle3 = birler(al) & arrChr
                    birles = birles & ekle1 & ekle2 & ekle3
                    If m > 0 Then birles = birles & binler(m) & arrChr
                End If
            End If
        Next x
    birles = Left(birles, Len(birles) - 1)
    yaziyaCevirParcala = Split(birles, "|")
End Function

Sub dene()
    For Each elem In yaziyaCevirParcala(123456789012345#)
        MsgBox elem
        'Debug.Print elem
    Next
End Sub

 

[hsayar]

teşekkürler hocam.... peki şöyle bir şey mümkünmü foınksiyonumzuda

Fonksiyon yazımını aşağıdaki gibi revize edip
Function yaziyaCevirParcala(Sayi As Double, Optional Ayraç As String = "Virgül", Optional SonKelime As String = "") As Variant

yaziyaCevirParcala(1450,101) yazdığımızda

ise dönecek değerler
bin
dört
yüz
elli
virgül
yüz
bir
şeklinde dönse


yaziyaCevirParcala(1450,15,"ytl ", "ykr" ) yazdığımızda ise dönecek değerler
bin
dört
yüz
elli
ytl
on
beş
ykr
gibi dönse valla bu şekli olursa çok muhteşem olacak

 

[veyselemre]

Function yaziyaCevirParcala(Sayi As Double, Optional Ayrac As String = "Virgül", Optional SonKelime As String = "") As Variant
Dim m As Byte
    say = Trim(Sayi)

    If Val(say) = 0 Then
        yaziyaCevirParcala = Array("sıfır")
        Exit Function
    End If

    birler = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
    onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
    binler = Array("", "bin", "milyon", "milyar", "trilyon")
    arrChr = " "

    bul = InStr(say, ".")

    If bul = 0 Then say = say & ".00": bul = InStr(say, ".")

    tam = Left(say, bul - 1): kesir = Replace(say, tam & ".", "")

    say = tam
    GoSub islem
    gec = birles & arrChr & Ayrac & arrChr

    say = kesir
    GoSub islem

    If SonKelime <> "" Then birles = birles & arrChr & SonKelime
    If SonKelime = "" And birles = "s&#305;f&#305;r " Then birles = ""

    birles = Trim(gec & birles)
    birles = Replace(birles, "   ", " ")
    birles = Replace(birles, "  ", " ")
    yaziyaCevirParcala = Split(birles, arrChr)

    Exit Function
islem:
    birles = ""
    uz = Len(say)
    If uz > 15 Then
        yaziyaCevirParcala = "HATA"
        Exit Function
    End If
    If Val(say) <> 0 Then
        say = String(15 - Len(say), "0") & say
        m = 5
        For x = 1 To 13 Step 3
            ekle1 = "": ekle2 = "": ekle3 = ""
            m = m - 1
            parca = Mid(say, x, 3)
            If Val(parca) > 0 Then
                If Val(parca) = 1 And m = 1 Then
                    birles = "bin" & arrChr
                Else
                    al = Val(Mid(parca, 1, 1))
                    If al > 0 Then
                        ekle1 = "y&#252;z" & arrChr
                        If al > 1 Then ekle1 = birler(al) & arrChr & ekle1
                    End If
                    al = Val(Mid(parca, 2, 1)): If al > 0 Then ekle2 = onlar(al) & arrChr

                    al = Val(Mid(parca, 3, 1))
                    If al > 0 Then ekle3 = birler(al) & arrChr
                    birles = birles & ekle1 & ekle2 & ekle3
                    If m > 0 Then birles = birles & binler(m) & arrChr
                End If
            End If
        Next x
    Else
        birles = "s&#305;f&#305;r" & arrChr
    End If
    Return
End Function

Sub dene()
    'For Each elem In yaziyaCevirParcala(1450.15, "ytl ", "ykr")
    For Each elem In yaziyaCevirParcala(1450.101)
        MsgBox elem
        'Debug.Print elem
    Next
End Sub

 

[hsayar]

Sn veysel hocam alakanıza teşekkür ederim virgülden sonraki kısımlar çalışmıyor yalnız ayrıca Virgül girilirse mesala 1,23 ü yüz - yirmi - üç gibi çeviryor.

 

[hsayar]

satırlarındaki noktaları virgül yaptım hata almadım başka yerde değişklik yapmam gerekir mi hocam.

...............
    bul = InStr(say, ",")

    If bul = 0 Then say = say & ".00": bul = InStr(say, ",")

    tam = Left(say, bul - 1): kesir = Replace(say, tam & ",", "")
..............

 

[veyselemre]

VBA'da ondalık işareti noktadır, fonsiyona girerken
yaziyaCevirParcala(1450.15, "ytl ", "ykr") şeklinde noktalı olarak gireceksiniz.

 

[hsayar]

VBA'da ondalık işareti noktadır, fonsiyona girerken
yaziyaCevirParcala(1450.15, "ytl ", "ykr") şeklinde noktalı olarak gireceksiniz.

Sub dene()
    'For Each elem In yaziyaCevirParcala(1450.15, "ytl ", "ykr")
    For Each elem In yaziyaCevirParcala(1450.101)
        MsgBox elem
        'Debug.Print elem
    Next
End Sub

şeklinde kullanıyorum. hata varmı hocam

 

[veyselemre]

Fonksiyona girerken giren parametrede double dır, bu şekilde hata vermemesi lazım.

    For Each elem In yaziyaCevirParcala(1.23)
        Debug.Print elem
    Next

olarak çalıştırdığımda çıkan sonuç,

bir
Virgül
yirmi
üç