Dolar Okutma Makrosu
26 Aralık 2020
26 Aralık 2020
754
Dolar Okutma Makrosu isimli kodda, yazılı olan bir dolar rakamını, yazıya çeviren kullanıcı tanımlı fonksiyon yer almaktadır.
Function DollarText(vNumber) As Variant
Dim sDollars As String
Dim sCents As String
Dim iLen As Integer
Dim sTemp As String
Dim iPos As Integer
Dim iHundreds As Integer
Dim iTens As Integer
Dim iOnes As Integer
Dim sUnits(2 To 5) As String
Dim bHit As Boolean
Dim vOnes As Variant
Dim vTeens As Variant
Dim vTens As Variant
If Not IsNumeric(vNumber) Then
Exit Function
End If
sDollars = Format(vNumber, "###0.00")
iLen = Len(sDollars) - 3
If iLen > 15 Then
DollarText = CVErr(xlErrNum)
Exit Function
End If
sCents = Right$(sDollars, 2) & "/100 Dollars"
If vNumber < 1 Then
DollarText = sCents
Exit Function
End If
sDollars = Left$(sDollars, iLen)
vOnes = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine")
vTeens = Array("Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
vTens = Array("", "", "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
sUnits(2) = "Thousand"
sUnits(3) = "Million"
sUnits(4) = "Billion"
sUnits(5) = "Trillion"
sTemp = ""
For iPos = 15 To 3 Step -3
If iLen >= iPos - 2 Then
bHit = False
If iLen >= iPos Then
iHundreds = Asc(Mid$(sDollars, iLen - iPos + 1, 1)) - 48
If iHundreds > 0 Then
sTemp = sTemp & " " & vOnes(iHundreds) & ""
Hundred ""
bHit = True
End If
End If
iTens = 0
iOnes = 0
If iLen >= iPos - 1 Then
iTens = Asc(Mid$(sDollars, iLen - iPos + 2, 1)) - 48
End If
If iLen >= iPos - 2 Then
iOnes = Asc(Mid$(sDollars, iLen - iPos + 3, 1)) - 48
End If
If iTens = 1 Then
sTemp = sTemp & " " & vTeens(iOnes)
bHit = True
Else
If iTens >= 2 Then
sTemp = sTemp & " " & vTens(iTens)
bHit = True
End If
If iOnes > 0 Then
If iTens >= 2 Then
sTemp = sTemp & "-"
Else
sTemp = sTemp & " "
End If
sTemp = sTemp & vOnes(iOnes)
bHit = True
End If
End If
If bHit And iPos > 3 Then
sTemp = sTemp & " " & sUnits(iPos \ 3)
End If
End If
Next iPos
DollarText = Trim(sTemp) & " and " & sCents
End Function 'DollarTextGerekli Adımlar
Kodu çalıştırmanız için aşağıdaki adımları yerine getirmeniz gerekir.
- Microsoft Visual Basic for Applications penceresini (Alt + F11) açın.
- Project - VBAProject alanının, ekranın sol tarafında görüldüğünden emin olun. Görünmüyorsa, Ctrl + R kısayolu ile hızlıca açın.
- Araç çubuklarından Insert -> Module yazısına tıklayın.
- Solunda klasör simgesi olan Modules yazısının başındaki + simgesine tıklayın.
- Alt kısma eklenecek gelecek olan Module(1) yazısına çift tıklayın.
- Üstteki kodu yapıştırın.
Kod Açıklaması
Kullanımı: =DollarText(A1) şeklindedir.
Etiketler :
| YARARLI KISAYOLLAR | |
|---|---|
| Yeni Kitap Oluşturma | Ctrl N |
| Yazdırma Alanı Belirlemek | Alt P M B |
| Yapıştır / Alternatif | Shift Insert |
| Kes İşlemi Kısayolu | Ctrl X |
| Hücreyi Araya Çoğaltarak Yerleştirme | Ctrl Shift Sürükle |