Featured Posts
Bedah Tunas Gadget: Convert Numbers to Text
Kali ini saya akan menjelaskan langkah demi langkah bagaimana cara membuat Convert Number to Text. Convert Numbers to Text bertujuan untuk merubah angka menjadi huruf terbilang seperti yang biasa terdapat dalam kwitansi. Convert Numbers to Text ini tersedia dalam bahasa Inggris dan bahasa Indonesia.
Kita mulai dengan membuat form terlebih dahulu dengan menekan Alt + F8 (Microsoft Visual Basic) lalu Insert > User Form.
Selanjutnya form kosong di atas didesain seperti gambar di bawah ini dengan menggunakan fungsi-fungsi yang ada dalam Toolbox:
Perhatikan nomor-nomor di atas. Nomor-nomor tersebut adalah untuk menjelaskan masing-masing properties, isi propertiesnya sbb:
1. Form
2. Reference Cell
3. Output Cell
4. Tombol radio English
5. Tombol radio Bahasa Indonesia
6. Tombol Convert
7. Tombol Exit
Untuk scriptnya pilih View > Code lalu gunakan script berikut:
1. Form
Private Sub UserForm_Activate()
opt_english.Value = True
cmd_run.SetFocus
End Sub
Private Sub UserForm_QueryClose _
(cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
cancel = True
End If
End Sub
6. Tombol Convert
Private Sub cmd_run_Click()
If Ref_cell.Value = "" Or Output_cell.Value = "" Then
MsgBox "Reference cell and Output cell must not be empty.", vbCritical + vbOKOnly, "Enter Reference and Output Cell"
Else
If Ref_cell.Value = Output_cell.Value Then
MsgBox "Reference cell and Output cell must not be the same. Please select other cell for Output Cell.", vbCritical + vbOKOnly, "Reference and Output Cell Error"
Else
If opt_english.Value = False Then
Range(Output_cell.Value).Select
ActiveCell.Value = "=dghrf(" & Ref_cell.Value & ")"
Else
Range(Output_cell.Value).Select
ActiveCell.Value = "=txtString(" & Ref_cell.Value & ")"
End If
End If
End If
End Sub
7. Tombol Exit
Private Sub cmd_cancel_Click()
Unload Me
End Sub
Selanjutnya pilih ThisWorkbook pada window Project – VBA Project dan gunakan script berikut pada window sebelah kanan:
Sub Open_Form_Convert2Text()
With Form_Convert2Text
.Show vbModeless
End With
End Sub
Sampai tahap di atas kita baru membuat tampilan interfacenya (GUI), sedang untuk mendefinisikan function =dghrf dan =txtString kita buat dengan 2 (dua) Modules. Pilih Insert > Module dan beri nama Angka2Text pada propertiesnya dan masukkan script di bawah ini:
Dim Huruf(0 To 9) As String
Dim ax(0 To 3) As Double
Function INIT_angka()
Huruf(0) = ""
Huruf(1) = "satu "
Huruf(2) = "dua "
Huruf(3) = "tiga "
Huruf(4) = "empat "
Huruf(5) = "lima "
Huruf(6) = "enam "
Huruf(7) = "tujuh "
Huruf(8) = "delapan "
Huruf(9) = "sembilan "
End Function
Function dgratus(angka As Double) As String
Temp = ""
INIT_angka
panjang = Len(Trim(Str(angka)))
nilai = Right("000", 3 - panjang) + Trim(Str(angka))
For y = 3 To 1 Step -1
ax(y) = Mid(nilai, y, 1)
Next y
Select Case ax(1)
Case Is = 1
Temp = "seratus "
Case Is > 1
Temp = Huruf(Val(ax(1))) + " " + "ratus "
Case Else
Temp = " "
End Select
Select Case ax(2)
Case Is = 0
Temp = Temp + Huruf(Val(ax(3)))
Case Is = 1
Select Case ax(3)
Case Is = 1
Temp = Temp + "sebelas "
Case Is = 0
Temp = Temp + "sepuluh "
Case Else
Temp = Temp + Huruf(Val(ax(3))) + "belas "
End Select
Case Is > 1
Temp = Temp + Huruf(Val(ax(2))) + "puluh "
Temp = Temp + " " + Huruf(Val(ax(3)))
End Select
dgratus = Temp
End Function
Function dghrf(angka As Double) As String
Dim ratusan(0 To 6) As String
Dim sebut(0 To 4) As String
sebut(1) = " ribu "
sebut(2) = " juta "
sebut(3) = " milyar "
sebut(4) = " trilyun "
panjang = Len(Trim(Str(angka)))
kali = Int(panjang / 3)
If Int(panjang / 3) * 3 <> panjang Then
kali = kali + 1
sisa = panjang - Int(panjang / 3) * 3
nilai = Right("000", 3 - sisa) + Trim(Str(angka))
Else
nilai = Trim(Str(angka))
End If
For x = 0 To kali
ratusan(kali - x) = Mid(nilai, x * 3 + 1, 3)
Next x
For y = kali To 1 Step -1
If y = 2 And Val(ratusan(y)) = 1 Then
Temp = Temp + "seribu"
Else
If Val(ratusan(y)) = 0 Then
Temp = Temp
Else
Temp = Temp + dgratus(Val(ratusan(y)))
Temp = Temp + sebut(y - 1)
End If
End If
Next y
dghrf = Application.Trim(Application.Proper(Temp)) + " Rupiah"
End Function
Selanjutnya pilih lagi Insert > Module dan beri nama Convert2Text pada propertiesnya. Masukkan script di bawah ini:
Public Function txtString(jumlah As Long)
jumlah = Application.Round(jumlah, 2)
If Application.IsNumber(jumlah) = True Then
Dim MyNum, Num1, NumLength, txString
Dim Million, Thousand, Hundred, myDecimal
Dim MyDollar, MyCent
Dim Space, Separator
Dim Digit1, Digit2, Digit3, Digit4, Digit5
Dim Digit6, Digit7, Digit8, Digit9
Dim Digit11, Digit12 'Decimals
Dim txRM
Dim Rng, i
Rng = Selection.Rows.Count
For i = 1 To Rng
MyDollar = "IDR " 'Must be within the
MyCent = "Sen " 'For Next Loop
'--------------------------------------------------
Digit1 = 0 'Resets numbers
Digit2 = 0
Digit3 = 0
Digit4 = 0
Digit5 = 0
Digit6 = 0
Digit7 = 0
Digit8 = 0
Digit9 = 0
Digit11 = 0
Digit12 = 0
Million = ""
Thousand = ""
Hundred = ""
myDecimal = ""
'--------------------------------------------------
Num1 = jumlah
MyNum = Format(Num1, "#0.00") 'Shows 2 decimal places
NumLength = Len(MyNum) 'Determines the length of the number
Select Case NumLength 'Length determines the
Case 12 'position of the text boxes
Digit1 = Mid(MyNum, 1, 1)
Digit2 = Mid(MyNum, 2, 1)
Digit3 = Mid(MyNum, 3, 1)
Digit4 = Mid(MyNum, 4, 1)
Digit5 = Mid(MyNum, 5, 1)
Digit6 = Mid(MyNum, 6, 1)
Digit7 = Mid(MyNum, 7, 1)
Digit8 = Mid(MyNum, 8, 1)
Digit9 = Mid(MyNum, 9, 1)
Digit11 = Mid(MyNum, 11, 1)
Digit12 = Mid(MyNum, 12, 1)
Case 11
Digit2 = Mid(MyNum, 1, 1)
Digit3 = Mid(MyNum, 2, 1)
Digit4 = Mid(MyNum, 3, 1)
Digit5 = Mid(MyNum, 4, 1)
Digit6 = Mid(MyNum, 5, 1)
Digit7 = Mid(MyNum, 6, 1)
Digit8 = Mid(MyNum, 7, 1)
Digit9 = Mid(MyNum, 8, 1)
Digit11 = Mid(MyNum, 10, 1)
Digit12 = Mid(MyNum, 11, 1)
Case 10
Digit3 = Mid(MyNum, 1, 1)
Digit4 = Mid(MyNum, 2, 1)
Digit5 = Mid(MyNum, 3, 1)
Digit6 = Mid(MyNum, 4, 1)
Digit7 = Mid(MyNum, 5, 1)
Digit8 = Mid(MyNum, 6, 1)
Digit9 = Mid(MyNum, 7, 1)
Digit11 = Mid(MyNum, 9, 1)
Digit12 = Mid(MyNum, 10, 1)
Case 9
Digit4 = Mid(MyNum, 1, 1)
Digit5 = Mid(MyNum, 2, 1)
Digit6 = Mid(MyNum, 3, 1)
Digit7 = Mid(MyNum, 4, 1)
Digit8 = Mid(MyNum, 5, 1)
Digit9 = Mid(MyNum, 6, 1)
Digit11 = Mid(MyNum, 8, 1)
Digit12 = Mid(MyNum, 9, 1)
Case 8
Digit5 = Mid(MyNum, 1, 1)
Digit6 = Mid(MyNum, 2, 1)
Digit7 = Mid(MyNum, 3, 1)
Digit8 = Mid(MyNum, 4, 1)
Digit9 = Mid(MyNum, 5, 1)
Digit11 = Mid(MyNum, 7, 1)
Digit12 = Mid(MyNum, 8, 1)
Case 7
Digit6 = Mid(MyNum, 1, 1)
Digit7 = Mid(MyNum, 2, 1)
Digit8 = Mid(MyNum, 3, 1)
Digit9 = Mid(MyNum, 4, 1)
Digit11 = Mid(MyNum, 6, 1)
Digit12 = Mid(MyNum, 7, 1)
Case 6
Digit7 = Mid(MyNum, 1, 1)
Digit8 = Mid(MyNum, 2, 1)
Digit9 = Mid(MyNum, 3, 1)
Digit11 = Mid(MyNum, 5, 1)
Digit12 = Mid(MyNum, 6, 1)
Case 5
Digit8 = Mid(MyNum, 1, 1)
Digit9 = Mid(MyNum, 2, 1)
Digit11 = Mid(MyNum, 4, 1)
Digit12 = Mid(MyNum, 5, 1)
Case 4
Digit9 = Mid(MyNum, 1, 1)
Digit11 = Mid(MyNum, 3, 1)
Digit12 = Mid(MyNum, 4, 1)
Case 3
Digit11 = Mid(MyNum, 2, 1)
Digit12 = Mid(MyNum, 3, 1)
Case 2
Digit12 = Mid(MyNum, 2, 1)
End Select
'--------------------------------------------------
'''Do million
If Digit1 <> 0 Or Digit2 <> 0 Or Digit3 <> 0 Then
Million = "Million "
End If
Dim M1
M1 = Digit1
Select Case M1
Case 0
M1 = ""
Case 1
M1 = "One Hundred "
Case 2
M1 = "Two Hundred "
Case 3
M1 = "Three Hundred "
Case 4
M1 = "Four Hundred "
Case 5
M1 = "Five Hundred "
Case 6
M1 = "Six Hundred "
Case 7
M1 = "Seven Hundred "
Case 8
M1 = "Eight Hundred "
Case 9
M1 = "Nine Hundred "
End Select
Dim M2
M2 = Digit2
Select Case M2
Case 0
M2 = ""
Case 1
M2 = ""
Case 2
M2 = "Twenty "
Case 3
M2 = "Thirty "
Case 4
M2 = "Forty "
Case 5
M2 = "Fifty "
Case 6
M2 = "Sixty "
Case 7
M2 = "Seventy "
Case 8
M2 = "Eighty "
Case 9
M2 = "Ninety "
End Select
Dim M3
M3 = Digit3
If Digit2 = 1 Then 'check against the number before
Select Case M3
Case 0
M3 = "Ten "
Case 1
M3 = "Eleven "
Case 2
M3 = "Twelve "
Case 3
M3 = "Thirteen "
Case 4
M3 = "Fourteen "
Case 5
M3 = "Fifteen "
Case 6
M3 = "Sixteen "
Case 7
M3 = "Seventeen "
Case 8
M3 = "Eighteen "
Case 9
M3 = "Nineteen "
End Select
Else
Select Case M3
Case 0
M3 = ""
Case 1
M3 = "One "
Case 2
M3 = "Two "
Case 3
M3 = "Three "
Case 4
M3 = "Four "
Case 5
M3 = "Five "
Case 6
M3 = "Six "
Case 7
M3 = "Seven "
Case 8
M3 = "Eight "
Case 9
M3 = "Nine "
End Select
End If
Million = M1 & M2 & M3 & Million
'----------------------------------------------------
'''Do thousand
If Digit4 <> 0 Or Digit5 <> 0 Or Digit6 <> 0 Then
Thousand = "Thousand "
End If
Dim T1
T1 = Digit4
Select Case T1
Case 0
T1 = ""
Case 1
T1 = "One Hundred "
Case 2
T1 = "Two Hundred "
Case 3
T1 = "Three Hundred "
Case 4
T1 = "Four Hundred "
Case 5
T1 = "Five Hundred "
Case 6
T1 = "Six Hundred "
Case 7
T1 = "Seven Hundred "
Case 8
T1 = "Eight Hundred "
Case 9
T1 = "Nine Hundred "
End Select
Dim T2
T2 = Digit5
Select Case T2
Case 0
T2 = ""
Case 1
T2 = ""
Case 2
T2 = "Twenty "
Case 3
T2 = "Thirty "
Case 4
T2 = "Forty "
Case 5
T2 = "Fifty "
Case 6
T2 = "Sixty "
Case 7
T2 = "Seventy "
Case 8
T2 = "Eighty "
Case 9
T2 = "Ninety "
End Select
Dim T3
T3 = Digit6
If Digit5 = 1 Then 'check against the number before
Select Case T3
Case 0
T3 = "Ten "
Case 1
T3 = "Eleven "
Case 2
T3 = "Twelve "
Case 3
T3 = "Thirteen "
Case 4
T3 = "Fourteen "
Case 5
T3 = "Fifteen "
Case 6
T3 = "Sixteen "
Case 7
T3 = "Seventeen "
Case 8
T3 = "Eighteen "
Case 9
T3 = "Nineteen "
End Select
Else
Select Case T3
Case 0
T3 = ""
Case 1
T3 = "One "
Case 2
T3 = "Two "
Case 3
T3 = "Three "
Case 4
T3 = "Four "
Case 5
T3 = "Five "
Case 6
T3 = "Six "
Case 7
T3 = "Seven "
Case 8
T3 = "Eight "
Case 9
T3 = "Nine "
End Select
End If
Thousand = T1 & T2 & T3 & Thousand
'----------------------------------------------------
'''Do hundred
If Digit6 <> 0 Or Digit7 <> 0 Or Digit8 <> 0 Then
Hundred = "Hundred "
End If
Dim H1
H1 = Digit7
Select Case H1
Case 0
H1 = ""
Case 1
H1 = "One Hundred "
Case 2
H1 = "Two Hundred "
Case 3
H1 = "Three Hundred "
Case 4
H1 = "Four Hundred "
Case 5
H1 = "Five Hundred "
Case 6
H1 = "Six Hundred "
Case 7
H1 = "Seven Hundred "
Case 8
H1 = "Eight Hundred "
Case 9
H1 = "Nine Hundred "
End Select
Dim H2
H2 = Digit8
Select Case H2
Case 0
H2 = ""
Case 1
H2 = ""
Case 2
H2 = "Twenty "
Case 3
H2 = "Thirty "
Case 4
H2 = "Forty "
Case 5
H2 = "Fifty "
Case 6
H2 = "Sixty "
Case 7
H2 = "Seventy "
Case 8
H2 = "Eighty "
Case 9
H2 = "Ninety "
End Select
Dim H3
H3 = Digit9
If Digit8 = 1 Then 'check against the number before
Select Case H3
Case 0
H3 = "Ten "
Case 1
H3 = "Eleven "
Case 2
H3 = "Twelve "
Case 3
H3 = "Thirteen "
Case 4
H3 = "Fourteen "
Case 5
H3 = "Fifteen "
Case 6
H3 = "Sixteen "
Case 7
H3 = "Seventeen "
Case 8
H3 = "Eighteen "
Case 9
H3 = "Nineteen "
End Select
Else
Select Case H3
Case 0
H3 = ""
Case 1
H3 = "One "
Case 2
H3 = "Two "
Case 3
H3 = "Three "
Case 4
H3 = "Four "
Case 5
H3 = "Five "
Case 6
H3 = "Six "
Case 7
H3 = "Seven "
Case 8
H3 = "Eight "
Case 9
H3 = "Nine "
End Select
End If
Hundred = H1 & H2 & H3
'----------------------------------------------------
'Do decimal
Dim D1
D1 = Digit11
Select Case D1
Case 0
D1 = ""
Case 1
D1 = ""
Case 2
D1 = "Twenty "
Case 3
D1 = "Thirty "
Case 4
D1 = "Forty "
Case 5
D1 = "Fifty "
Case 6
D1 = "Sixty "
Case 7
D1 = "Seventy "
Case 8
D1 = "Eighty "
Case 9
D1 = "Ninety "
End Select
Dim D2
D2 = Digit12
If Digit11 = 1 Then 'check against the number before
Select Case D2
Case 0
D2 = "Ten "
Case 1
D2 = "Eleven "
Case 2
D2 = "Twelve "
Case 3
D2 = "Thirteen "
Case 4
D2 = "Fourteen "
Case 5
D2 = "Fifteen "
Case 6
D2 = "Sixteen "
Case 7
D2 = "Seventeen "
Case 8
D2 = "Eighteen "
Case 9
D2 = "Nineteen "
End Select
Else
Select Case D2
Case 0
D2 = ""
Case 1
D2 = "One "
Case 2
D2 = "Two "
Case 3
D2 = "Three "
Case 4
D2 = "Four "
Case 5
D2 = "Five "
Case 6
D2 = "Six "
Case 7
D2 = "Seven "
Case 8
D2 = "Eight "
Case 9
D2 = "Nine "
End Select
End If
myDecimal = D1 & D2
'--------------------------------------------------
'--------------------------------------------------
If Million = "" And Thousand = "" And Hundred = "" Then
MyDollar = ""
Space = ""
Separator = ""
Else: Space = " "
Separator = "And "
End If
If myDecimal = "" Then
MyCent = ""
Separator = ""
End If
If txRM = "" Then
Space = "" 'So that the 1st digit will not have a gap in front
End If
txtString = MyDollar & Space & Million & Thousand & Hundred & Separator & MyCent & myDecimal
'ActiveCell = txtString
'ActiveCell.Offset(1, 0).Select
Next i
Exit Function
Else
MsgBox "The cell must contain a number", vbCritical, "Macro Error"
End If
End Function
Untuk menjalankan macro ini silahkan balik ke window Microsoft Excel lalu tekan Alt + F8 lalu pilih Open_Form_Convert2Text dan klik Run.
Untuk lebih lengkap mengenai penggunaan macro ini, silahkan buka artikel Convert Numbers to Text.
Selamat mencoba!
Bedah Tunas Gadget: Change Case
Kali ini saya akan mencoba membedah source code dari salah satu fitur Tunas Gadget yaitu Change Case. Change Case bertujuan untuk merubah huruf besar dan kecil pada sel Excel menjadi HURUF BESAR (UPPERCASE), huruf kecil (lower case), Huruf kalimat (Sentense case) dan Huruf Judul (Title Case). Jika fitur ini mudah didapatkan di Microsoft Word, maka untuk di Microsoft Excel kita bisa menggunakan fitur ini.
Di sini saya menggunakan form sebagai Graphic User Interface (GUI) atau antar muka agar kita bisa lebih mudah menjalankan fungsinya dibanding kita menggunakan function-function yang terpisah. Karena dalam fitur Change Case ini terdapat 8 function sehingga akan lebih mudah jika kita menggunakan form daripada 8 function tersebut.
Kita dapat membuat sebuah file baru yang disimpan sebagai file Excel Add-in atau sebagai file excel biasa. Saran saya kita memilih sebagai file Excel Add-in.
Selanjutnya kita membuat form dengan menekan tombol Alt + F8 (Microsoft Visual Basic) lalu Insert > User Form sehingga muncul seperti gambar berikut:
Dengan menggunakan tombol-tombol di Toolbox, silahkan desain form kosong tersebut seperti form di bawah.
Perhatikan nomor-nomornya. Contoh nomor 1 adalah untuk Form, maka isi propertiesnya sesuai petunjuk gambar di bawah ini. Begitu juga untuk nomor 2 hingga 8, ikuti petunjuk propertiesnya.
1. Form
2. UPPERCASE
3. lower case
6. Textbox
7. Run Macro
8. Exit
Setelah form sudah selesai didesain, selanjutnya kita masuk ke bagian source code/scriptnya. Untuk scriptnya pilih View > Code lalu gunakan script berikut:
1. Form
Private Sub UserForm_Activate()
cmd_run.SetFocus
End Sub
Private Sub UserForm_QueryClose _
(cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
cancel = True
End If
End Sub
2. Tombol Radio UPPER CASE
Private Sub opt_upper_Click()
Label2.Caption = "Text will be changed as " & vbCrLf & "UPPER CASE."
End Sub
3. Tombol Radio lower case
Private Sub opt_lower_Click()
Label2.Caption = "Text will be changed as " & vbCrLf & "lower case."
End Sub
4. Tombol Radio Sentence case
Private Sub opt_sentence_Click()
Label2.Caption = "Text will be changed as " & vbCrLf & "Sentence case."
End Sub
5. Tombol Radio Title Case
Private Sub opt_title_Click()
Label2.Caption = "Text will be changed as " & vbCrLf & "Title Case."
End Sub
7. Tombol Run Macro
Private Sub cmd_run_Click()
On Error GoTo ErrorHandler:
If opt_upper = False And opt_lower = False And opt_sentence = False And opt_title = False Then
MsgBox "Please choose a case how text should be changed", vbExclamation + vbOKOnly, "Choose Method"
Else
If opt_upper = True Then
Dim cell_upper As Range
For Each cell_upper In Selection.Cells
If cell_upper.HasFormula = False Then
cell_upper = UCase(cell_upper)
End If
Next
Else
If opt_lower = True Then
Dim cell_lower As Range
For Each cell_lower In Selection.Cells
If cell_lower.HasFormula = False Then
cell_lower = LCase(cell_lower)
End If
Next
Else
If opt_sentence = True Then
For Each cell In Selection.Cells
s = cell.Value
Start = True
For i = 1 To Len(s)
ch = Mid(s, i, 1)
Select Case ch
Case "."
Start = True
Case "?"
Start = True
Case "a" To "z"
If Start Then ch = UCase(ch): Start = False
Case "A" To "Z"
If Start Then Start = False Else ch = LCase(ch)
End Select
Mid(s, i, 1) = ch
Next
cell.Value = s
Next
Else
If opt_title = True Then
Dim cell_title As Range
For Each cell_title In Selection.Cells
If cell_title.HasFormula = False Then
cell_title = Application.Proper(cell_title)
End If
Next
End If
End If
End If
End If
End If
GoTo WrapUp:
ErrorHandler:
MsgBox "Error Macro. Please contact doddy_151619@yahoo.com for further enhancement.", vbCritical + vbOKOnly, "Error Macro"
WrapUp:
Application.Interactive = True
Application.ScreenUpdating = True
End Sub
8. Tombol Exit
Private Sub cmd_cancel_Click()
Unload Me
End Sub
Selanjutnya pilih ThisWorkbook pada window Project – VBA Project dan gunakan script berikut pada window sebelah kanan:
Sub Open_Form_Change_Case()
With Form_Change_Case
.Show vbModeless
End With
End Sub
Untuk menjalankan macro ini silahkan balik ke window Microsoft Excel lalu tekan Alt + F8 lalu pilih Open_Form_Change_Case dan klik Run.
Untuk cara penggunaan macro ini, silahkan buka artikel Tunas Gadget: Change Case.
Selamat mencoba!
