-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Çok eski bir web tarayıcısı kullanıyorsunuz. Bu veya diğer siteleri görüntülemekte sorunlar yaşayabilirsiniz..
Tarayıcınızı güncellemeli veya alternatif bir tarayıcı kullanmalısınız.
Tarayıcınızı güncellemeli veya alternatif bir tarayıcı kullanmalısınız.
Rakamı Yazıya Çevirme
- Konbuyu başlatan zecbaron
- Başlangıç tarihi
- Katılım
- 28 Ocak 2007
- Mesajlar
- 1,585
- Excel Vers. ve Dili
- ofis 2010 turkce
mustafa1205
Altın Üye
- Katılım
- 23 Ekim 2010
- Mesajlar
- 1,436
- Excel Vers. ve Dili
- Office 2016 / 64 Bit - Türkçe
İlgili makro bütün sayıları doğru olarak yazıya çeviriyor. Sadece yüzlü sayılarda yazının başına "bir" ifadesini koyuyor.
Ayrıca kuruş hanesi sıfır olduğu zamanda krş ifadesini ekliyor.
İlgili dosya ektedir. Yardımlarınız için teşekkür ederim.
Saygılar.
Ayrıca kuruş hanesi sıfır olduğu zamanda krş ifadesini ekliyor.
İlgili dosya ektedir. Yardımlarınız için teşekkür ederim.
Saygılar.
Rakamı yazıya çevirme
İlgili makro bütün sayıları doğru olarak yazıya çeviriyor. Sadece yüzlü sayılarda yazının başına "bir" ifadesini koyuyor.
Ayrıca kuruş hanesi sıfır olduğu zamanda krş ifadesini ekliyor.
İlgili dosya ektedir. Yardımlarınız için teşekkür ederim.
Saygılar.
__________________
Option Explicit
Function SpellmoneyTL(ByVal MyNumber)
Dim TL, KR, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Bin "
Place(3) = " Milyon "
Place(4) = " Milyar "
Place(5) = " Trilyon "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
KR = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp <> "" Then TL = Temp & Place(Count) & TL
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case TL
Case ""
TL = " Türk Lirası"
Case ""
TL = " Türk Lirası"
Case Else
TL = TL & " Türk Lirası"
End Select
Select Case KR
Case ""
KR = " Kuruş"
Case ""
KR = " Kuruş"
Case Else
KR = " " & KR & " Kuruş"
End Select
SpellmoneyTL = TL & KR
End Function
Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If
GetHundreds = Result
End Function
Function GetTens(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "On"
Case 11: Result = "OnBir"
Case 12: Result = "Onİki"
Case 13: Result = "OnÜç"
Case 14: Result = "OnDört"
Case 15: Result = "OnBeş"
Case 16: Result = "OnAltı"
Case 17: Result = "OnYedi"
Case 18: Result = "OnSekiz"
Case 19: Result = "OnDokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Yirmi "
Case 3: Result = "Otuz "
Case 4: Result = "Kırk "
Case 5: Result = "Elli "
Case 6: Result = "Altmış "
Case 7: Result = "Yetmiş "
Case 8: Result = "Seksen "
Case 9: Result = "Doksan "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens = Result
End Function
Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "Bir"
Case 2: GetDigit = "İki"
Case 3: GetDigit = "Üç"
Case 4: GetDigit = "Dört"
Case 5: GetDigit = "Beş"
Case 6: GetDigit = "Altı"
Case 7: GetDigit = "Yedi"
Case 8: GetDigit = "Sekiz"
Case 9: GetDigit = "Dokuz"
Case Else: GetDigit = ""
End Select
End Function
Function SpellMoneyE(ByVal MyNumber)
Dim Euro, EuroCent, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Bin "
Place(3) = " Milyon "
Place(4) = " Milyar "
Place(5) = " Trilyon "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
EuroCent = GetTens2(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds2(Right(MyNumber, 3))
If Temp <> "" Then Euro = Temp & Place(Count) & Euro
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Euro
Case ""
Euro = " Euro"
Case "One"
Euro = "One Euro"
Case Else
Euro = Euro & " Euro"
End Select
Select Case EuroCent
Case ""
EuroCent = " EuroCent"
Case "One"
EuroCent = " EuroCent"
Case Else
EuroCent = " " & EuroCent & " EuroCent"
End Select
SpellMoneyE = Euro & EuroCent
End Function
Function GetHundreds2(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit2(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens2(Mid(MyNumber, 2))
Else
Result = Result & GetDigit2(Mid(MyNumber, 3))
End If
GetHundreds2 = Result
End Function
Function GetTens2(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "On"
Case 11: Result = "OnBir"
Case 12: Result = "Onİki"
Case 13: Result = "OnÜç"
Case 14: Result = "OnDört"
Case 15: Result = "OnBeş"
Case 16: Result = "OnAltı"
Case 17: Result = "OnYedi"
Case 18: Result = "OnSekiz"
Case 19: Result = "OnDokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Yirmi "
Case 3: Result = "Otuz "
Case 4: Result = "Kırk "
Case 5: Result = "Elli "
Case 6: Result = "Altmış "
Case 7: Result = "Yetmiş "
Case 8: Result = "Seksen "
Case 9: Result = "Doksan "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens2 = Result
End Function
Function GetDigit2(Digit)
Select Case Val(Digit)
Case 1: GetDigit2 = "Bir"
Case 2: GetDigit2 = "İki"
Case 3: GetDigit2 = "Üç"
Case 4: GetDigit2 = "Dört"
Case 5: GetDigit2 = "Beş"
Case 6: GetDigit2 = "Altı"
Case 7: GetDigit2 = "Yedi"
Case 8: GetDigit2 = "Sekiz"
Case 9: GetDigit2 = "Dokuz"
Case Else: GetDigit2 = ""
End Select
End Function
Function SpellMoneyD(ByVal MyNumber)
Dim Dolar, Cent, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Bin "
Place(3) = " Milyon "
Place(4) = " Milyar "
Place(5) = " Trilyon "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
Cent = GetTens3(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds3(Right(MyNumber, 3))
If Temp <> "" Then Dolar = Temp & Place(Count) & Dolar
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Dolar
Case ""
Dolar = " Dolar"
Case ""
Dolar = " Dolar"
Case Else
Dolar = Dolar & " Dolar"
End Select
Select Case Cent
Case ""
Cent = " Cent"
Case "One"
Cent = " Cent"
Case Else
Cent = " " & Cent & " Cent"
End Select
SpellMoneyD = Dolar & Cent
End Function
Function GetHundreds3(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit3(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens3(Mid(MyNumber, 2))
Else
Result = Result & GetDigit3(Mid(MyNumber, 3))
End If
GetHundreds3 = Result
End Function
Function GetTens3(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "On"
Case 11: Result = "OnBir"
Case 12: Result = "Onİki"
Case 13: Result = "OnÜç"
Case 14: Result = "OnDört"
Case 15: Result = "OnBeş"
Case 16: Result = "OnAltı"
Case 17: Result = "OnYedi"
Case 18: Result = "OnSekiz"
Case 19: Result = "OnDokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Yirmi "
Case 3: Result = "Otuz "
Case 4: Result = "Kırk "
Case 5: Result = "Elli "
Case 6: Result = "Altmış "
Case 7: Result = "Yetmiş "
Case 8: Result = "Seksen "
Case 9: Result = "Doksan "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens3 = Result
End Function
Function GetDigit3(Digit)
Select Case Val(Digit)
Case 1: GetDigit3 = "Bir"
Case 2: GetDigit3 = "İki"
Case 3: GetDigit3 = "Üç"
Case 4: GetDigit3 = "Dört"
Case 5: GetDigit3 = "Beş"
Case 6: GetDigit3 = "Altı"
Case 7: GetDigit3 = "Yedi"
Case 8: GetDigit3 = "Sekiz"
Case 9: GetDigit3 = "Dokuz"
Case Else: GetDigit3 = ""
End Select
End Function
İlgili makro bütün sayıları doğru olarak yazıya çeviriyor. Sadece yüzlü sayılarda yazının başına "bir" ifadesini koyuyor.
Ayrıca kuruş hanesi sıfır olduğu zamanda krş ifadesini ekliyor.
İlgili dosya ektedir. Yardımlarınız için teşekkür ederim.
Saygılar.
__________________
Option Explicit
Function SpellmoneyTL(ByVal MyNumber)
Dim TL, KR, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Bin "
Place(3) = " Milyon "
Place(4) = " Milyar "
Place(5) = " Trilyon "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
KR = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp <> "" Then TL = Temp & Place(Count) & TL
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case TL
Case ""
TL = " Türk Lirası"
Case ""
TL = " Türk Lirası"
Case Else
TL = TL & " Türk Lirası"
End Select
Select Case KR
Case ""
KR = " Kuruş"
Case ""
KR = " Kuruş"
Case Else
KR = " " & KR & " Kuruş"
End Select
SpellmoneyTL = TL & KR
End Function
Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If
GetHundreds = Result
End Function
Function GetTens(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "On"
Case 11: Result = "OnBir"
Case 12: Result = "Onİki"
Case 13: Result = "OnÜç"
Case 14: Result = "OnDört"
Case 15: Result = "OnBeş"
Case 16: Result = "OnAltı"
Case 17: Result = "OnYedi"
Case 18: Result = "OnSekiz"
Case 19: Result = "OnDokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Yirmi "
Case 3: Result = "Otuz "
Case 4: Result = "Kırk "
Case 5: Result = "Elli "
Case 6: Result = "Altmış "
Case 7: Result = "Yetmiş "
Case 8: Result = "Seksen "
Case 9: Result = "Doksan "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens = Result
End Function
Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "Bir"
Case 2: GetDigit = "İki"
Case 3: GetDigit = "Üç"
Case 4: GetDigit = "Dört"
Case 5: GetDigit = "Beş"
Case 6: GetDigit = "Altı"
Case 7: GetDigit = "Yedi"
Case 8: GetDigit = "Sekiz"
Case 9: GetDigit = "Dokuz"
Case Else: GetDigit = ""
End Select
End Function
Function SpellMoneyE(ByVal MyNumber)
Dim Euro, EuroCent, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Bin "
Place(3) = " Milyon "
Place(4) = " Milyar "
Place(5) = " Trilyon "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
EuroCent = GetTens2(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds2(Right(MyNumber, 3))
If Temp <> "" Then Euro = Temp & Place(Count) & Euro
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Euro
Case ""
Euro = " Euro"
Case "One"
Euro = "One Euro"
Case Else
Euro = Euro & " Euro"
End Select
Select Case EuroCent
Case ""
EuroCent = " EuroCent"
Case "One"
EuroCent = " EuroCent"
Case Else
EuroCent = " " & EuroCent & " EuroCent"
End Select
SpellMoneyE = Euro & EuroCent
End Function
Function GetHundreds2(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit2(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens2(Mid(MyNumber, 2))
Else
Result = Result & GetDigit2(Mid(MyNumber, 3))
End If
GetHundreds2 = Result
End Function
Function GetTens2(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "On"
Case 11: Result = "OnBir"
Case 12: Result = "Onİki"
Case 13: Result = "OnÜç"
Case 14: Result = "OnDört"
Case 15: Result = "OnBeş"
Case 16: Result = "OnAltı"
Case 17: Result = "OnYedi"
Case 18: Result = "OnSekiz"
Case 19: Result = "OnDokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Yirmi "
Case 3: Result = "Otuz "
Case 4: Result = "Kırk "
Case 5: Result = "Elli "
Case 6: Result = "Altmış "
Case 7: Result = "Yetmiş "
Case 8: Result = "Seksen "
Case 9: Result = "Doksan "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens2 = Result
End Function
Function GetDigit2(Digit)
Select Case Val(Digit)
Case 1: GetDigit2 = "Bir"
Case 2: GetDigit2 = "İki"
Case 3: GetDigit2 = "Üç"
Case 4: GetDigit2 = "Dört"
Case 5: GetDigit2 = "Beş"
Case 6: GetDigit2 = "Altı"
Case 7: GetDigit2 = "Yedi"
Case 8: GetDigit2 = "Sekiz"
Case 9: GetDigit2 = "Dokuz"
Case Else: GetDigit2 = ""
End Select
End Function
Function SpellMoneyD(ByVal MyNumber)
Dim Dolar, Cent, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Bin "
Place(3) = " Milyon "
Place(4) = " Milyar "
Place(5) = " Trilyon "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
Cent = GetTens3(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds3(Right(MyNumber, 3))
If Temp <> "" Then Dolar = Temp & Place(Count) & Dolar
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Dolar
Case ""
Dolar = " Dolar"
Case ""
Dolar = " Dolar"
Case Else
Dolar = Dolar & " Dolar"
End Select
Select Case Cent
Case ""
Cent = " Cent"
Case "One"
Cent = " Cent"
Case Else
Cent = " " & Cent & " Cent"
End Select
SpellMoneyD = Dolar & Cent
End Function
Function GetHundreds3(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit3(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens3(Mid(MyNumber, 2))
Else
Result = Result & GetDigit3(Mid(MyNumber, 3))
End If
GetHundreds3 = Result
End Function
Function GetTens3(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "On"
Case 11: Result = "OnBir"
Case 12: Result = "Onİki"
Case 13: Result = "OnÜç"
Case 14: Result = "OnDört"
Case 15: Result = "OnBeş"
Case 16: Result = "OnAltı"
Case 17: Result = "OnYedi"
Case 18: Result = "OnSekiz"
Case 19: Result = "OnDokuz"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Yirmi "
Case 3: Result = "Otuz "
Case 4: Result = "Kırk "
Case 5: Result = "Elli "
Case 6: Result = "Altmış "
Case 7: Result = "Yetmiş "
Case 8: Result = "Seksen "
Case 9: Result = "Doksan "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens3 = Result
End Function
Function GetDigit3(Digit)
Select Case Val(Digit)
Case 1: GetDigit3 = "Bir"
Case 2: GetDigit3 = "İki"
Case 3: GetDigit3 = "Üç"
Case 4: GetDigit3 = "Dört"
Case 5: GetDigit3 = "Beş"
Case 6: GetDigit3 = "Altı"
Case 7: GetDigit3 = "Yedi"
Case 8: GetDigit3 = "Sekiz"
Case 9: GetDigit3 = "Dokuz"
Case Else: GetDigit3 = ""
End Select
End Function
Ekli dosyalar
İ
İhsan Tank
Misafir
İlgili makro bütün sayıları doğru olarak yazıya çeviriyor. Sadece yüzlü sayılarda yazının başına "bir" ifadesini koyuyor.
Ayrıca kuruş hanesi sıfır olduğu zamanda krş ifadesini ekliyor.
İlgili dosya ektedir. Yardımlarınız için teşekkür ederim.
Saygılar.
bu link işinizi görür mü_?
İhsan bey, gönderdiğiniz kod çok düzgün çalışıyor ve işimi fazlasıyla gördü. Teşekkür ederim.
Saygılarımla,
-
Sizlere daha iyi bir deneyim sunabilmek icin sitemizde çerez konumlandırmaktayız, web sitemizi kullanmaya devam ettiğinizde çerezler ile toplanan kişisel verileriniz Veri Politikamız / Bilgilendirmelerimizde belirtilen amaçlar ve yöntemlerle mevzuatına uygun olarak kullanılacaktır.