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.

#Dolar Okutma Makrosy
50 Farklı Hazır Makro (VBA) Kodu
Formu Kapatma Makro Kodu
Hesap Makinesini Açma
UserForm Resize Özelliği Eklemek
Sütunu Kes Kopyala ve Yapıştır
Excel Makroları ile Klasör Silme
Her Bir Sütundaki Maksimum Değeri Bulma
Dolar Okutma Makrosu
Dizileri İç İçe Döngüye Eklemek
Transparan UserForm Oluşturmak
Satır Yüksekliğini Ayarla
Açılışta Üç Kere Şifre Hakkı Vermek
Tüm Satırda İşlem Yapan Döngü
Hücrede Değişiklik Olduğunda Makroyu Çalıştırma
Listbox ve Combobox Satır Kaydırma
Aktif Hücrenin Satır Numarasını Bulma
Çalışma Sayfaları için Yakınlaştırma Yüzdesini Ayarlama
Son Dolu Satırın Bir Altına Yazdırma
Excel Makroları ile Form Çağırma
Top 10 Değeri Renklendirme
Açılışta İstediğiniz Sayfanın Aktif Edilmesi
Excel Satır Silme Kodu
Excel Kitabındaki Sayfa Adlarının Listelenmesi
Seçili Hücrenin Sütun Harfini Bulma
Excel Makroları ile İşlemci Bilgilerini Bulma
Yorumları İçeren Hücreleri Renklendirme
Kopyala ve Özel Yapıştır
Excel Satır Seçme Kodu
Gizli Sayfaların Bulunması ve Gösterilmesi
MsgBox ile Uyarı Çıkarma Kodu
Kopyala ve Biçimleri Yapıştır
Excel Üzerinden Klasör Açma Kodu
Kullanılan Tüm Sütunları Otomatik Sığdır
Excel Menüsüne Ekleme Yapma Kodu
Excel Dosya Silme İşlemi Makrosu
Hücrenin Rengini Değiştirme
Excel Hücresine Gitme Makrosu
Makro ile Boş Satırları Silme
Belirli Kriterlere Sahip Satırları Silme
Başka Dosyada Şifreli Userform Oluşturmak
Excel Makroları ile Klasör Arama
UserForm Kapatma Kodu
Kes Kopyala ve Başka Çalışma Kitabına Yapıştır
Excel Crackleme İşlemi Makrosu
Şeffaf UserForm Oluşturma Kodu
Hatalı Hücreleri Renklendirme
Açılışta UserForm Nesnesinin Otomatik Gösterilmesi
Aktif Hücrenin Sütun Numarasını Bulma
Seçili Sütunların Sayısını Bulma
Seçilmiş Alanı Kes Kopyala ve Yapıştır
Hücre Aralığını Kes Kopyala ve Yapıştır
Üstteki alanda, Google Reklamları yerine sizin reklamınızın yayınlanmasını ister misiniz?
Reklam vermek istiyorum

Daha önce yorum yapılmamış!

Aşağıdaki resimde olduğu gib bir tablonuz olduğunu ve belirtildiği gibi sütun eklemeniz gerektiğini varsayalım.

bir seferde çoklu sütun ekleme

Excel kullanıcıları burada genelde sütunlara tek tek seçerek birden fazla seferde sütun ekleme işlemini yapmaktadır. Bunu bir tık kısaltmanın yolu ise:

Sütunları birbiri ardına seçin (seçerken Ctrl tuşunu basılı tutun, fare ile bir kerede seçim yapmayın).
Sütun başlığını sağ tıklayın ve Ekle'yi seçin - bu, seçilen sütunların her biri için araya bir sütun ekler.

bir seferde çoklu sütun ekleme
Yükleniyor...