Excelde Sayıları Metin Olarak Yazdırma Kodu - Yüzler Basamağı

axedice · Kasım 1, 2012

Excelde sayıları metin olarak yazdırmak için (örneğin 1.350,45 i "Bin üç yüz elli lira 45 kuruş" gibi) bi VBA kodu buldum internetten, sonra bunu tercüme ettim gayet güzel çalışıyor. Ahanda şudur :

Kodun Tamamı



	Option Explicit

	'Main Function

	Function SpellNumber(ByVal MyNumber)

	    Dim Dollars, Cents, Temp

	    Dim DecimalPlace, Count

	    ReDim Place(9) As String

	    Place(2) = " Bin "

	    Place(3) = " Milyon "

	    Place(4) = " Milyar "

	    Place(5) = " Trilyon "

	    ' String representation of amount.

	    MyNumber = Trim(Str(MyNumber))

	    ' Position of decimal place 0 if none.

	    DecimalPlace = InStr(MyNumber, ".")

	    ' Convert cents and set MyNumber to dollar amount.

	    If DecimalPlace > 0 Then

	        Cents = 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 Dollars = Temp & Place(Count) & Dollars

	        If Len(MyNumber) > 3 Then

	            MyNumber = Left(MyNumber, Len(MyNumber) - 3)

	        Else

	            MyNumber = ""

	        End If

	        Count = Count + 1

	    Loop

	    Select Case Dollars

	        Case ""

	            Dollars = ""

	        Case "One"

	            Dollars = "Lira"

	         Case Else

	            Dollars = Dollars & " Lira"

	    End Select

	    Select Case Cents

	        Case ""

	            Cents = " "

	        Case "One"

	            Cents = " Kuruş"

	              Case Else

	            Cents = " ve " & Cents & " Kuruş"

	    End Select

	    SpellNumber = Dollars & Cents

	End Function

	      

	' Converts a number from 100-999 into text

	Function GetHundreds(ByVal MyNumber)

	    Dim Result As String

	    If Val(MyNumber) = 0 Then Exit Function

	    MyNumber = Right("000" & MyNumber, 3)

	    ' Convert the hundreds place.

	    If Mid(MyNumber, 1, 1) <> "0" Then

	        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz "

	    End If

	    ' Convert the tens and ones place.

	    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

	      

	' Converts a number from 10 to 99 into text.

	Function GetTens(TensText)

	    Dim Result As String

	    Result = ""           ' Null out the temporary function value.

	    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...

	        Select Case Val(TensText)

	            Case 10: Result = "On"

	            Case 11: Result = "Onbir"

	            Case 12: Result = "Oniki"

	            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                                 ' If value between 20-99...

	        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))  ' Retrieve ones place.

	    End If

	    GetTens = Result

	End Function

	     

	' Converts a number from 1 to 9 into text.

	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

Yalnız ingilizce ve türkçenin sayı okunmasında ayrıldığı iki nokta var, ingilizcede yüzler basamağı 1 olsa bile rakamı okurken türkçede okumuyorsunuz, ve 1000 - 2000 arasında bir sayıyı okruken bir bin demiyorsunuz, fakat onbinler basamağı geldiği anda "bir"bin şeklinde okunmaya başlanıyor.

Misal 1.500 ü gevur one thousand five hundred diye okuyor, biz bir bin beş yüz demiyoruz. Hatta daha kötüsü sayı 1.100 olunca gavur one thousand one hundered diyor, bunu yukardaki kodla çevirince bir bin bir yüz gibi garabet bişey çıkıyor otaya.

Kodda büyük ihtimal şu bölgede değişiklik yapmak lazım fakat baya yabancıyım bu VBA işine, bi el atarsanız sevinirim.

Yüzler



	' Converts a number from 100-999 into text

	Function GetHundreds(ByVal MyNumber)

	    Dim Result As String

	    If Val(MyNumber) = 0 Then Exit Function

	    MyNumber = Right("000" & MyNumber, 3)

	    ' Convert the hundreds place.

	    If Mid(MyNumber, 1, 1) <> "0" Then

	        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz "

	    End If

	    ' Convert the tens and ones place.

	    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

Çözene tantuni ısmarlıyorum. Öpenzi

Baggio · Kasım 1, 2012

axedice said:

Yüzler

' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
' Convert the hundreds place.
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz "
End If
If Mid(MyNumber, 1, 1) = "1" Then Result = " Yüz "
Else If Mid(MyNumber, 1, 1) > "1" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz "
End If
' Convert the tens and ones place.
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

"Bir yüz" demesini engellemek için şu yeterli olacaktır gibi geliyor ama excel yok bulunduğum makinede, deneyemedim. Binler olayına da gece çözülmezse yarın bakayım, vaktim yok loopu inceleyecek kadar şu anda valla :p

fizban · Kasım 1, 2012

ne zaman ısmarlıyon ?

kod çok çirkin olduğu için daha da çirkinleşti. ama işi çözüyo haha



	'Main Function

	Function SpellNumber(ByVal MyNumber)

	    Dim Dollars, Cents, Temp

	    Dim DecimalPlace, Count

	    ReDim Place(9) As String

	    Place(2) = " Bin "

	    Place(3) = " Milyon "

	    Place(4) = " Milyar "

	    Place(5) = " Trilyon "

	    ' String representation of amount.

	    MyNumber = Trim(Str(MyNumber))

	    ' Position of decimal place 0 if none.

	    DecimalPlace = InStr(MyNumber, ".")

	    ' Convert cents and set MyNumber to dollar amount.

	    If DecimalPlace > 0 Then

	        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _

	                  "00", 2))

	        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

	    End If

	    Count = 1

	    Do While MyNumber <> ""

	        Dim Ones

	        If Dollars <> "" And Len(MyNumber) = 1 Then

	            Ones = 0

	        Else

	            Ones = 1

	        End If

	        Temp = GetHundreds(Right(MyNumber, 3), Ones)

	        Dollars = Temp & Place(Count) & Dollars

	        If Len(MyNumber) > 3 Then

	            MyNumber = Left(MyNumber, Len(MyNumber) - 3)

	        Else

	            MyNumber = ""

	        End If

	        Count = Count + 1

	    Loop

	    Select Case Dollars

	        Case ""

	            Dollars = ""

	        Case "One"

	            Dollars = "Lira"

	         Case Else

	            Dollars = Dollars & " Lira"

	    End Select

	    Select Case Cents

	        Case ""

	            Cents = " "

	        Case "One"

	            Cents = " Kuruş"

	              Case Else

	            Cents = " ve " & Cents & " Kuruş"

	    End Select

	    SpellNumber = Dollars & Cents

	End Function

	      

	' Converts a number from 100-999 into text

	Function GetHundreds(ByVal MyNumber, ByVal Ones)

	    Dim Result As String

	    If Val(MyNumber) = 0 Then Exit Function

	    MyNumber = Right("000" & MyNumber, 3)

	    ' Convert the hundreds place.

	    If Mid(MyNumber, 1, 1) <> "0" Then

	        Result = GetDigit(Mid(MyNumber, 1, 1), 0) & " Yüz "

	    End If

	    ' Convert the tens and ones place.

	    If Mid(MyNumber, 2, 1) <> "0" Then

	        Result = Result & GetTens(Mid(MyNumber, 2, 1))

	    End If

	    Result = Result & GetDigit(Mid(MyNumber, 3), Ones)

	    GetHundreds = Result

	End Function

	      

	' Converts a number from 10 to 99 into text.

	Function GetTens(TensText)

	    Select Case Val(Left(TensText, 1))

	            Case 1: Result = "On "

	            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

	    GetTens = Result

	End Function

	     

	' Converts a number from 1 to 9 into text.

	Function GetDigit(Digit, Ones)

	    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

	    If Ones = 0 And Digit = 1 Then

	        GetDigit = ""

	    End If

	End Function

axedice · Kasım 1, 2012

Uuu beybi ferrari gibi çalışıyor mübarek. İstanbula ilk gelişimde tantunini ısmarlıyorum bebeyim, teşek! :)-D

Baggio sana da çabandan ötürü mansiyon ödülü tatlı ısmarlayabilirirdim de paso hata veriyor kod döngüleri kapatmamışsın ifsiz elseler koymuşsun falan. Ama hadi iyi niyetten çorban benden :P

Kharon · Kasım 1, 2012

Once gorseydim ben de yazardim. iyi niyetten bana ne var?

fizban · Kasım 1, 2012

bayadır canım tantuni istiyodu, iyi oldu.

barbu · Kasım 1, 2012

ucuza kapatmışlar seni bence. kesin şimdi iş yerindeki kızlara hava atıp kız kapatıcak bakın excel de neler yapıyorum diye. bariz ayran da iste

axedice · Kasım 12, 2012

fizban said:

ne zaman ısmarlıyon ?

kod çok çirkin olduğu için daha da çirkinleşti. ama işi çözüyo haha



	'Main Function

	Function SpellNumber(ByVal MyNumber)

	    Dim Dollars, Cents, Temp

	    Dim DecimalPlace, Count

	    ReDim Place(9) As String

	    Place(2) = " Bin "

	    Place(3) = " Milyon "

	    Place(4) = " Milyar "

	    Place(5) = " Trilyon "

	    ' String representation of amount.

	    MyNumber = Trim(Str(MyNumber))

	    ' Position of decimal place 0 if none.

	    DecimalPlace = InStr(MyNumber, ".")

	    ' Convert cents and set MyNumber to dollar amount.

	    If DecimalPlace > 0 Then

	        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _

	                  "00", 2))

	        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

	    End If

	    Count = 1

	    Do While MyNumber <> ""

	        Dim Ones

	        If Dollars <> "" And Len(MyNumber) = 1 Then

	            Ones = 0

	        Else

	            Ones = 1

	        End If

	        Temp = GetHundreds(Right(MyNumber, 3), Ones)

	        Dollars = Temp & Place(Count) & Dollars

	        If Len(MyNumber) > 3 Then

	            MyNumber = Left(MyNumber, Len(MyNumber) - 3)

	        Else

	            MyNumber = ""

	        End If

	        Count = Count + 1

	    Loop

	    Select Case Dollars

	        Case ""

	            Dollars = ""

	        Case "One"

	            Dollars = "Lira"

	         Case Else

	            Dollars = Dollars & " Lira"

	    End Select

	    Select Case Cents

	        Case ""

	            Cents = " "

	        Case "One"

	            Cents = " Kuruş"

	              Case Else

	            Cents = " ve " & Cents & " Kuruş"

	    End Select

	    SpellNumber = Dollars & Cents

	End Function

	      

	' Converts a number from 100-999 into text

	Function GetHundreds(ByVal MyNumber, ByVal Ones)

	    Dim Result As String

	    If Val(MyNumber) = 0 Then Exit Function

	    MyNumber = Right("000" & MyNumber, 3)

	    ' Convert the hundreds place.

	    If Mid(MyNumber, 1, 1) <> "0" Then

	        Result = GetDigit(Mid(MyNumber, 1, 1), 0) & " Yüz "

	    End If

	    ' Convert the tens and ones place.

	    If Mid(MyNumber, 2, 1) <> "0" Then

	        Result = Result & GetTens(Mid(MyNumber, 2, 1))

	    End If

	    Result = Result & GetDigit(Mid(MyNumber, 3), Ones)

	    GetHundreds = Result

	End Function

	      

	' Converts a number from 10 to 99 into text.

	Function GetTens(TensText)

	    Select Case Val(Left(TensText, 1))

	            Case 1: Result = "On "

	            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

	    GetTens = Result

	End Function

	     

	' Converts a number from 1 to 9 into text.

	Function GetDigit(Digit, Ones)

	    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

	    If Ones = 0 And Digit = 1 Then

	        GetDigit = ""

	    End If

	End Function

Ferrari dedim skoda çıktı, kuruşlarda 1/100 basamağını okumuyor. Misal 3,28 çıkarsa üç lira yirmi kuruş diyor =(

pic related

http://aibek2.nomadlife.org/uploaded_images/Image019-763537.jpg

axedice · Kasım 20, 2012

Fizbancım sağolsun hatalı olan kodu değiştirmiş, biraz daha iyi şu anda. Bu arada bi yerde parantez falan unutmuşsun onun düzeltilmiş halini koyuyorum, bide caps yaptım rakamları capsli capsli okuyor.

Kod



	'Main Function

	Function SpellNumber(ByVal MyNumber)

	Dim Dollars, Cents, Temp

	Dim DecimalPlace, Count

	ReDim Place(9) As String

	Place(2) = " BİN "

	Place(3) = " MİLYON "

	Place(4) = " MİLYAR "

	Place(5) = " TRİLYON "

	' String representation of amount.

	MyNumber = Trim(Str(MyNumber))

	' Position of decimal place 0 if none.

	DecimalPlace = InStr(MyNumber, ".")

	' Convert cents and set MyNumber to dollar amount.

	If DecimalPlace > 0 Then

	Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _

	"00", 2), 1)

	MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

	End If

	Count = 1

	Do While MyNumber <> ""

	Dim Ones

	If Dollars <> "" And Len(MyNumber) = 1 Then

	Ones = 0

	Else

	Ones = 1

	End If

	Temp = GetHundreds(Right(MyNumber, 3), Ones)

	Dollars = Temp & Place(Count) & Dollars

	If Len(MyNumber) > 3 Then

	MyNumber = Left(MyNumber, Len(MyNumber) - 3)

	Else

	MyNumber = ""

	End If

	Count = Count + 1

	Loop

	Select Case Dollars

	Case ""

	Dollars = ""

	Case "One"

	Dollars = "LİRA"

	Case Else

	Dollars = Dollars & " LİRA"

	End Select

	Select Case Cents

	Case ""

	Cents = " "

	Case "One"

	Cents = " KURUŞ"

	Case Else

	Cents = " " & Cents & " KURUŞ"

	End Select

	SpellNumber = Dollars & Cents

	End Function

	

	' Converts a number from 100-999 into text

	Function GetHundreds(ByVal MyNumber, ByVal Ones)

	Dim Result As String

	If Val(MyNumber) = 0 Then Exit Function

	MyNumber = Right("000" & MyNumber, 3)

	' Convert the hundreds place.

	If Mid(MyNumber, 1, 1) <> "0" Then

	Result = GetDigit(Mid(MyNumber, 1, 1), 0) & " YÜZ "

	End If

	' Convert the tens and ones place.

	If Mid(MyNumber, 2, 1) <> "0" Then

	Result = Result & GetTens(Mid(MyNumber, 2, 1))

	End If

	Result = Result & GetDigit(Mid(MyNumber, 3), Ones)

	GetHundreds = Result

	End Function

	

	' Converts a number from 10 to 99 into text.

	Function GetTens(TensText, Optional IsKurus = 0)

	Select Case Val(Left(TensText, 1))

	Case 1: Result = "ON "

	Case 2: Result = "YİRMİ "

	Case 3: Result = "OTUZ "

	Case 4: Result = "KIRK "

	Case 5: Result = "ELLİ "

	Case 6: Result = "ALTMIŞ "

	Case 7: Result = "YETMİŞ "

	Case 8: Result = "SEKSEN "

	Case 9: Result = "DOKSAN "

	Case Else

	End Select

	If (IsKurus = 1) Then

	Result = Result & GetDigit(Right(TensText, 1), 1) ' Retrieve ones place.

	End If

	GetTens = Result

	End Function

	

	' Converts a number from 1 to 9 into text.

	Function GetDigit(Digit, Ones)

	Select Case Val(Digit)

	Case 1: GetDigit = "BİR"

	Case 2: GetDigit = "İKİ"

	Case 3: GetDigit = "ÜÇ"

	Case 4: GetDigit = "DÖRT"

	Case 5: GetDigit = "BEŞ"

	Case 6: GetDigit = "ALTI"

	Case 7: GetDigit = "YEDİ"

	Case 8: GetDigit = "SEKİZ"

	Case 9: GetDigit = "DOKUZ"

	Case Else: GetDigit = ""

	End Select

	If Ones = 0 And Digit = 1 Then

	GetDigit = ""

	End If

	End Function

AMA

Diyelim sayı bir milyon küsur, buna bir milyon değil milyon diyor. Ama onbir milyon olunca mesela onu normal okuyor. Vur deyince öldürmüşsün yani, insan milyonlar ve milyarlar basamaklarında ortaya çıkabilecek sorunları da düşünür ona göre kod yazar.

İyi niyetinle tantuniyi kazandın ama üzerine tatlı zor. Baya slacker bi iş olmuş sonunda.

Giriş

Excelde Sayıları Metin Olarak Yazdırma Kodu - Yüzler Basamağı

Öne çıkan mesajlar

axedice

Link to comment

Sosyal ağlarda paylaş

Baggio

Link to comment

Sosyal ağlarda paylaş

fizban

Link to comment

Sosyal ağlarda paylaş

axedice

Link to comment

Sosyal ağlarda paylaş

Kharon

Link to comment

Sosyal ağlarda paylaş

fizban

Link to comment

Sosyal ağlarda paylaş

barbu

Link to comment

Sosyal ağlarda paylaş

axedice

Link to comment

Sosyal ağlarda paylaş

axedice

Link to comment

Sosyal ağlarda paylaş