Dolar Okutma Makrosu

Dolar Okutma Makrosu isimli kodda, yazılı olan bir dolar rakamını, yazıya çeviren kullanıcı tanımlı fonksiyon yer almaktadır.

XD Destek İste
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 'DollarText

Gerekli Adımlar

Kodu çalıştırmanız için aşağıdaki adımları yerine getirmeniz gerekir.

  1. Microsoft Visual Basic for Applications penceresini (Alt + F11) açın.
  2. 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.
  3. Araç çubuklarından Insert -> Module yazısına tıklayın.
  4. Solunda klasör simgesi olan Modules yazısının başındaki + simgesine tıklayın.
  5. Alt kısma eklenecek gelecek olan Module(1) yazısına çift tıklayın.
  6. Üstteki kodu yapıştırın.

Kod Açıklaması

Kullanımı: =DollarText(A1) şeklindedir.

Etiketler

50 Farklı Hazır Makro (VBA) Kodu
Son Dolu Satırın Bir Altına Yazdırma
Her Bir Sütundaki Maksimum Değeri Bulma
Makro Etkinletirilmezse Sayfalar Gizlenir
Toplu Sütun Silme
Excel ile Demo Yapma Makrosu
Yanıp Sönme Efekti Verme Kodu
R1C1 Referans Stilini Etkinleştirme
TextBox Nesnesinde Kuruş Göstermek
Tarih ve Saatten Saati Kaldırma
Sayfa Üzerindeki Formüllerin Sayısını Bulma
Kes Kopyala ve Başka Çalışma Kitabına Yapıştır
Bir Kitaptaki Sayfaları Başka Kitaba Taşıma
Sayfadaki Kelime ve Sayı Adetlerini Bulma
Gizlenmiş Makro Örnekleri
Boş Hücreleri Sıfırlarla Değiştirme
Çoklu Bulma ve Karşısındaki Değeri Listeleme
Bir Aralıktaki Minimum Değeri Renklendirme
ListBbox ve ComboBox Satır Kaydırma
Boş Hücreleri Vurgulama
Tarih ve Saatten Tarihi Kaldırma
Metnin İçinden TC Kimlik Numarasını Ayırma
Tüm Formülleri Değerlere Dönüştürme
UserForm Kapatma Kodu
Hücrede Değişiklik Olduğunda Makroyu Çalıştırma
Aktif Hücrenin Üstüne Satır Ekleme
Makro Çalışırken İmlecin Hareket Etmemesini Sağlama
Negatif Sayıları Poztif Sayıya Çevirme
Kare Kökünü Hesaplama
Tüm Sütunda İşlem Yapan Döngü
Bir Çalışma Kitabında Kaç Sayfa Var
Excel Makro Modulü Silme Kodu
Hücrenin Arka Plan Rengini Değiştirme
Aktif Çalışma Sayfası Korumasını Kaldırma
Makro ile Boş Satırları Silme
Belirli Kriterlere Sahip Satırları Silme
Cümle Durumuna Dönüştürme
Şeffaf UserForm Oluşturma Kodu
Metin Sarmayı Kaldırma
Boşluk Olan Hücreleri Renklendirme
Derece Simgesi Ekleme
Seçili Hücrelerden Boşlukları Kaldırma
2. Satırdaki Bilgileri Silmek
Kapanış Mesajı Ekleme
Bir Aralığa Alfabenin Harflerini Ekleme
Seçilmiş Alanı Kes Kopyala ve Yapıştır
Verileri Tek Sütuna Göre Sıralama
Otomatik Olarak Tarih ve Zaman Ekleme
Çalışma Kitabını Kapatırken Otomatik Kaydetme
Son Sütun Numarasını Bulma
Excel Tam Ekran Yapma
Üstteki alanda, Google Reklamları yerine sizin reklamınızın yayınlanmasını ister misiniz?
Reklam vermek istiyorum

Daha önce yorum yapılmamış!

#YOK! (#NULL?) Hatası

Formülde bazı yerlerde ya noktalı birgül yerine virgül kullanmışsınızdır. Ya da başvurulan hücrelerde başvuru bilgisi bulunamamıştır. Çoğunlukla Düşeyara, yatayara gibi formül sonuçlarında bu hata alınabiliyor.

Detaylı bilgi için buradaki makalemizi inceleyebilirsiniz.
Yükleniyor...