Dolar Okutma Makrosu

26 Aralık 2020 26 Aralık 2020 542

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 '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.

50 Farklı Hazır Makro (VBA) Kodu
Çalışma Kitabındaki Tüm Pivot Tabloları Yenileme
Sütunları Otomatik Sığdırma
A Sütunundaki Verileri C Sütununda Sıralama
Boş Hücreleri Vurgulama
Özel Sayfaları Yazdırma
Makrolar İşlem Yaparken Ekranın Kilitlenmesi
Excel Seçenekleri Penceresini Açma
Klasörde Dosya Araması Yapma
Birden Çok Satır Ekleme
Makro Çalışırken İmlecin Hareket Etmemesi
Belli Sütunlarda Alfabetik Sıralama
Excel Makroları ile Hücreye Saat Ekleme
56 Koşula Kadar Biçimlendirme Yapma
Birden Çok Sütun Ekleme
Disk Sürücü Kapasitesini Gösterme
Seçili Satırların Sayısını Bulma
Bir Sayfadaki Veriyi Diğer Sayfalara Kopyalama
Çalışma Kitabını E-Posta Ekine Ekleme
Excel ile Faiz Hesaplama Kodu
UserForm Resize Özelliği Eklemek
Sürücü Seri Numarasını Gösterme
Açık Excel Kitaplarını Yerleştirme
Çalışma Sayfasını Kaydetme
Seçili Aralığa Ait Bilgilerin Listelenmesi
Bilgisayardaki Sürücü Sayısını Bulma
Aktif Hücreye Günün Tarihini Yazma
Otomatik Olarak Tarih ve Zaman Ekleme
Makrolar ile Eliptik Form Oluşturma
Excel Satır Silme Kodu
Negatif Sayıları Vurgulama
Adlandırılmış Aralıkları Vurgulama
Tüm Çalışma Kitaplarını Aynı Anda Kapatma
Kilitlenmemiş Hücreleri Seçme İşlemi
Excel Makroları ile İşlemci Bilgilerini Bulma
Etkin Sayfa Hariç Çalışma Sayfalarını Gizleme
Kopyala ve Değer Olarak Yapıştır
Makro ile Git Penceresini Açma
Tekrar Eden Verileri Farklı Sütunda Yazma
Cümle Durumuna Dönüştürme
Kopyala ve Biçimleri Yapıştır
Hücrenin Rengini Değiştirme
Makro ile Web Sitesini Açmak
Makro ile Hızlı Doldurma
Bir sayfadaki Veriyi Diğer Sayfaya Aktarma
Hangi Günde Olduğunu Bulma
Açıklama İçeren Tüm Hücreleri Vurgulama
Tam Dizin İsmini Bulma
Satır Yüksekliklerini Otomatik Ayarlama
Seçili Sütunların Sayısını Bulma
Tüm Boş Çalışma Sayfalarını Silme

Daha önce yorum yapılmamış!

Backlink Reklam Bu alanda 50 karakterlik açıklama ile web sitenize ait Backlink Reklam yayınlayabilirsiniz.
Yükleniyor...