Coding VBA Dasar

1. Input Data :
Private Sub CMB_OK_Click()
Dim baris As Long
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
baris = Ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
Ws.Cells(baris, 1).Value = Me.TextBox1.Value
Ws.Cells(baris, 2).Value = Me.TextBox2.Value
Ws.Cells(baris, 3).Value = Me.TextBox3.Value
Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
Me.TextBox1.SetFocus
End Sub
2. Hanya Data Numerik Yang Boleh Di Entri Ke Textbox :
Private Sub Text1_KeyPress(KeyAscii As Integer)

    If Not (KeyAscii >= Asc("0") & Chr(13) _

    And KeyAscii <= Asc("9") & Chr(13) _

        Or KeyAscii = vbKeyBack _

        Or KeyAscii = vbKeyDelete _

        Or KeyAscii = vbKeySpace) Then

            Beep

            KeyAscii = 0

   End If

End Sub
3. Gak Bisa Close :

 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        Me.Caption = "Klik tombol Tutup!"
    End If
End Sub
4. Cara munculin Userform :
 Private Sub Workbook_Open()
Application.Visible = False
tabungan.Show
Application.Visible = True
End Sub
5. Tutup Langsung Simpan :
Private Sub CMB_Tutup_Click()
Unload Me
ThisWorkbook.Save
Application.Visible = False
ThisWorkbook.Close
End Sub
6. OptionButton :
Private Sub obd_Click()
If Me.obd.Value = True Then
Label1.Caption = "D"
Else
Label1.Caption = "K"
End If
End Sub

Private Sub obk_Click()
If Me.obk.Value = True Then
Label1.Caption = "K"
Else
Label1.Caption = "D"
End If
End Sub
7. PrintOut :
Sheets("Sheet1").Select
ActiveSheet.Range("A1:H50").PrintOut
8. Menampilkan Jam Dan Tanggal Pada UserForm :
 Private Sub UserForm_Activate()
Do Until Berhenti
    Label1 = FormatDateTime(Date, vbLongDate) & " " & FormatDateTime(Time, vbLongTime)
    Label2 = FormatDateTime(Time, vbLongTime)
    DoEvents
Loop
End Sub
9. Format Rupiah :
 TextBox10.Value = Format(TextBox10, """Rp. ""*##,0.00")
10. Terbilang Rupiah :
 Public Function Rupiah(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 > 1E+15 Then
Rupiah = ""
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, milyard, juta, ribu, rupiah dan sen
Triliun = Int(x / 1000 ^ 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 trilliun
If Triliun > 0 Then
baca = Ratus(Triliun, 5) + "Triliun "
End If
'baca bagian milyar dan ditambah akhiran milyar
If Milyar > 0 Then
baca = 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
If Ribu = 1 Then
baca = baca + "Seribu "
Else

baca = baca + Ratus(Ribu, 2) + "Ribu "
End If
End If
'baca bagian rupiah dan ditambah akhiran rupiah
If Satu > 0 Then
baca = baca + Ratus(Satu, 1) + ""
End If
'sebelum bagian sen
baca = baca & "Rupiah "
'baca bagian sen dan ditambah akhiran sen
If Sen > 0 Then
baca = baca + Ratus(Sen, 0) + "Sen "
End If
End If
Rupiah = 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)
If a100 = 1 Then
baca = "Seratus "
Else
If a100 > 0 Then
baca = angka(a100, Posisi) + "ratus "
End If
End If
'baca bagian puluhan 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 <= 2 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
11. Rumus Terbilang :
Function Terbilang(n As Long) As String 'max 2.147.483.647
Dim satuan As Variant, Minus As Boolean
On Error GoTo terbilang_error
satuan = Array("", "Satu", "Dua", "Tiga", "Empat", "Lima", "Enam", "Tujuh", "Delapan", "Sembilan", "Sepuluh", "Sebelas")
If n < 0 Then
Minus = True
n = n * -1
End If
Select Case n
Case 0 To 11
Terbilang = " " + satuan(Fix(n))
Case 12 To 19
Terbilang = Terbilang(n Mod 10) + " Belas"
Case 20 To 99
Terbilang = Terbilang(Fix(n / 10)) + " Puluh" + Terbilang(n Mod 10)
Case 100 To 199
Terbilang = " Seratus" + Terbilang(n - 100)
Case 200 To 999
Terbilang = Terbilang(Fix(n / 100)) + " Ratus" + Terbilang(n Mod 100)
Case 1000 To 1999
Terbilang = " Seribu" + Terbilang(n - 1000)
Case 2000 To 999999
Terbilang = Terbilang(Fix(n / 1000)) + " Ribu" + Terbilang(n Mod 1000)
Case 1000000 To 999999999
Terbilang = Terbilang(Fix(n / 1000000)) + " Juta" + Terbilang(n Mod 1000000)
Case Else
Terbilang = Terbilang(Fix(n / 1000000000)) + " Milyar" + Terbilang(n Mod 1000000000)
End Select
If Minus = True Then
Terbilang = "Minus" + Terbilang
End If
Exit Function
terbilang_error:
MsgBox Err.Description, vbCritical, "^_^Terbilang Error"
End Function
12. Input Data Langsung Urut :
Private Sub CommandButton1_Click()
Dim Ws As Worksheet
Dim Baris As Integer
Set Ws = Worksheets("sheet1")
Baris = WorksheetFunction.CountA(Range("a:a")) + 1
Ws.Cells(Baris, 1) = TextBox1
Ws.Cells(Baris, 2) = TextBox2
Ws.Cells(Baris, 3) = TextBox3
TextBox1 = ""
TextBox2 = ""
TextBox3 = ""
TextBox1.SetFocus
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:c10")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
13. Nomor Otomatis :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, jumlahbaris As Integer
jumlahbaris = 4 + Application.WorksheetFunction.CountA(Range("B5:B1000"))
If jumlahbaris <> 4 Then
For i = 5 To jumlahbaris
If Range("A" & i).Value = "" Then
Range("A" & i).Value = i - 4
End If
Next i
End If
End Sub
14. Panggil VBA :
Private Sub CommandButton1_Click()
ThisWorkbook.VBProject.VBE.MainWindow.Visible = True
End Sub
15. Teks Berjalan :
Private Sub Worksheet_Activate()
Call TeksBerjalan
End Sub
Function TeksBerjalan()
Dim Teks1 As String
Dim teks2 As String
Dim i As Integer, j As Integer
Dim Mulai, Penundaan As Variant
Dim Batas As Single
Dim BlnKanan As Boolean
  
On Error Resume Next
Batas = 40
Teks1 = "Black Excel"
teks2 = "PDSS"

Do While Sheets("Beranda").Range("A1").Value <> "Berhenti"
DoEvents
For j = 1 To 2
    For i = 1 To Batas
         Mulai = Timer
         Penundaan = Mulai + 0.03
    Do While Timer < Penundaan
            If BlnKanan Then
               Sheets("Beranda").Range("A1") = Space(Batas - i) & Teks1
               Sheets("Beranda").Range("A2") = Space(i) & teks2
            Else
               Sheets("Beranda").Range("A1") = Space(i) & Teks1
               Sheets("Beranda").Range("A2") = Space(Batas - i) & teks2
            End If
            DoEvents
         Loop
      Mulai = Timer
      Penundaan = Mulai + 0.03
      If i = Batas Then BlnKanan = Not (BlnKanan)
   Next i
Next j
Loop
Sheets("Beranda").Range("A1") = ""
Sheets("Beranda").Range("A2") = ""
End Function
16. Teks Berjalan Dan Keblit-keblit :
Di ThisWorkbook :
Sub StartLoop()
    Dim kalimat As String, MT As Long, PjgStrg As Long, TmpPjgStrg As Long
    Dim maju As Boolean, i As Double
    kalimat = "Saya nggak suka situ baca-baca tulisan saya"
    PjgStrg = Len(kalimat)
    TmpPjgStrg = 1
    MT = 1
    maju = True
    Range("A5").HorizontalAlignment = xlRight
  
Anim:
    If maju Then
        Range("A5").Value = Mid(kalimat, 1, TmpPjgStrg)
        TmpPjgStrg = TmpPjgStrg + 1
        If TmpPjgStrg > PjgStrg Then
            maju = False
            Range("A5").HorizontalAlignment = xlLeft
        End If
    Else
        Range("A5").Value = Mid(kalimat, MT, PjgStrg)
        MT = MT + 1
        If MT > PjgStrg Then
            maju = True
            TmpPjgStrg = 0
            MT = 1
            Range("A5").HorizontalAlignment = xlRight
        End If
    End If
  
    DoEvents
    For i = 1 To 4200000: Next i 'ini untuk delaynya, bila nilai semakin besar animasi akan semakin lambat
  
    ' If Brhenti Then End  -->ini sekedar inspirasi buat menghentikan animasi
    '                         Variable ini mesti diset global dgn type data Boolean
  
GoTo Anim   'kembali ke Anim dan begitu seterusnya

End Sub

Di Module :
Public RunWhen As Double
Sub berkedip()
With ThisWorkbook.Worksheets("Sheet1").Range("A1,c1").Font
If .ColorIndex = 5 Then ' Warna biru
.ColorIndex = 2 ' Warna putih
Else
If .ColorIndex = 2 Then ' Warna hijau
.ColorIndex = 5 ' Warna merah
Else
.ColorIndex = 5 ' Warna biru
End If
End If
End With

RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime RunWhen, "'" & ThisWorkbook.Name & "'!Berkedip", , True
End Sub

Sub Berhenti()
On Error Resume Next
ThisWorkbook.Worksheets("Sheet1").Range("A1").Font.ColorIndex = xlColorIndexAutomatic
Application.OnTime RunWhen, "'" & ThisWorkbook.Name & "'!Berkedip", , False
End Sub