Sunday, May 25, 2008

Membuat fungsi Terbilang()

Excel 97|2000|2002|2003|2007


MS Excel juga bisa menampilkan angka secara terbilang. Bagimana caranya ?

Anda harus membuat fungsi terlebih dahulu di vba (dengan menekan tombol Alt+F11)
Copy-kan script berikut ini dalam vba anda.
---

Public Function Terbilang(x As Currency)
Dim triliun As Currency
Dim milyar As Currency
Dim juta As Currency
Dim ribu As Currency
Dim satu As Currency
Dim sen As Currency
Dim baca As String
If x > 1000000000000# Then
Terbilang = "<>"
Exit Function
End If
'Jika x adalah 0, maka dibaca sebagai 0
If x = 0 Then
baca = angka(0, 1)
Else
'Pisah masing-masing bagian untuk triliun, milyar, juta, ribu, rupiah, dan sen
triliun = Int(x * 0.001 ^ 4)
milyar = Int((x - triliun * 1000 ^ 4) * 0.001 ^ 3)
juta = Int((x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3) / 1000 ^ 2)
ribu = Int((x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2) / 1000)
satu = Int(x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2 - ribu * 1000)
sen = Int((x - Int(x)) * 100)
'Baca bagian triliun dan ditambah akhiran triliun
If triliun > 0 Then
baca = ratus(triliun, 5) + "triliun "
End If
'Baca bagian milyar dan ditambah akhiran milyar
If milyar > 0 Then
baca = ratus(milyar, 4) + "milyar "
End If
'Baca bagian juta dan ditambah akhiran juta
If juta > 0 Then
baca = baca + ratus(juta, 3) + "juta "
End If
'Baca bagian ribu dan ditambah akhiran ribu
If ribu > 0 Then
baca = baca + ratus(ribu, 2) + "ribu "
End If
'Baca bagian rupiah dan ditambah akhiran rupiah
If satu > 0 Then
baca = baca + ratus(satu, 1) + "rupiah "
Else
baca = baca + "rupiah"
End If
'Baca bagian sen dan ditambah akhiran sen
If sen > 0 Then
baca = baca + ratus(sen, 0) + "sen"
End If
End If
Terbilang = UCase(Left(baca, 1)) & LCase(Mid(baca, 2))
End Function

Function ratus(x As Currency, Posisi As Integer) As String
Dim a100 As Integer, a10 As Integer, a1 As Integer
Dim baca As String
a100 = Int(x * 0.01)
a10 = Int((x - a100 * 100) * 0.1)
a1 = Int(x - a100 * 100 - a10 * 10)
'Baca Bagian Ratus
If a100 = 1 Then
baca = "Seratus "
Else
If a100 > 0 Then
baca = angka(a100, Posisi) + "ratus "
End If
End If
'Baca Bagian Puluh dan Satuan
If a10 = 1 Then
baca = baca + angka(a10 * 10 + a1, Posisi)
Else
If a10 > 0 Then
baca = baca + angka(a10, Posisi) + "puluh "
End If
If a1 > 0 Then
baca = baca + angka(a1, Posisi)
End If
End If
ratus = baca
End Function

Function angka(x As Integer, Posisi As Integer)
Select Case x
Case 0: angka = "Nol"
Case 1:
If Posisi <= 1 Or Posisi > 2 Then
angka = "Satu "
Else
angka = "Se"
End If
Case 2: angka = "Dua "
Case 3: angka = "Tiga "
Case 4: angka = "Empat "
Case 5: angka = "Lima "
Case 6: angka = "Enam "
Case 7: angka = "Tujuh "
Case 8: angka = "Delapan "
Case 9: angka = "Sembilan "
Case 10: angka = "Sepuluh "
Case 11: angka = "Sebelas "
Case 12: angka = "Duabelas "
Case 13: angka = "Tigabelas "
Case 14: angka = "Empatbelas "
Case 15: angka = "Limabelas "
Case 16: angka = "Enambelas "
Case 17: angka = "Tujuhbelas "
Case 18: angka = "Delapanbelas "
Case 19: angka = "Sembilanbelas "
End Select
End Function

---
Untuk mencobanya anda tinggal memanggil fungsi tersebut =terbilang(12) atau mereferensikan ke sel lain dengan =terbilang(b12)
silahkan dicoba.

Semoga bermanfaat.

8 comments:

yogi said...

terbilang.txt nya kok gak ada
ketika di klik

Anonymous said...

klo jumlah text melebihi dari cell yang sudah ditentukan gimana donk caranya.thank

Nanang said...

@Anonymous: Tinggal dimodifikasi aja penentuan cellnya.

@Yogi: Link externalnya kemaren sudah tidak ada jadi saya masukkan ke artikel.

Terima kasih.

ipunk said...

assalamualaikum..
setelah saya membuat fungsi di vba saya(dengan menekan tombol Alt+F11)kemudian
Copy-kan script yang ada..ternyata setelah di coba gak bisa..knp??
mkc atas jawabannya..
---

Anonymous said...

dok reti donk

Nanang said...

@ipunk:
Di Ms.Office biasanya ada setingan security untuk bisa eksekusi script VBA, mungkin setingannya masih belum allow script/macros.

Silahkan di cek dan semoga membantu.

Anil Kumar Pal said...

Intersting and beautiful blog lovely presentation thanks for sharing your views...Microsoft Outlook Support We24support tech team are available 24/7 for repairs on computers, printers, laptops, desktops. Our tech team taken to new heights with our technician’s knowledge and support.at 1-866-978-0799 ms word support

Anonymous said...

coba 1,01 apa bisa dibaca satu koma nol satu?
coba 7,00 apa bisa tujuh koma nol nol?
mohon dibantu ya to anton_gesi@yahoo.com