Home Macro Excel Kode-kode VBA Macro Excel Yang Sering Digunakan

Kode-kode VBA Macro Excel Yang Sering Digunakan

Di sini saya merangkum beberapa kode VBA Macro Excel yang sering digunakan. Hal ini sengaja saya tampilkan untuk memudahkan pencarian dan penggunaan kode Macro tersebut. 



Menyembunyikan dan Menampilkan Tombol

Sub Rectangle1_Click()
    
    If Sheets("Sheet1").Range("C2") = 2 Then
    ActiveSheet.Shapes("picture").Visible = xlhiden
    End If

    If Sheets("Sheet1").Range("C2") = 1 Then
    ActiveSheet.Shapes("picture").Visible = True
    End If

End Sub





Menyembunyikan dan Menampilkan Gambar


Sub Rectangle4_Click()
    If Sheets("Sheet1").Range("C9") = 2 Then
    ActiveSheet.Shapes("picture 2").Visible = xlhiden
    End If

    If Sheets("Sheet1").Range("C9") = 1 Then
    ActiveSheet.Shapes("picture 2").Visible = True
    End If

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Static oldRange As Range
Dim nRow As Integer, nCol As Integer
If Not oldRange Is Nothing Then
nRow = oldRange.Row
nCol = oldRange.Column
If nRow > 1 Then 'Menampilkan nomor urut otomatis.
If Len(Cells(nRow, 2).Value) > 0 Then
Cells(nRow, 1).Formula = "=COUNTA($B$2:B" & nRow & ")"
Else: Cells(nRow, 1).Value = ""
End If
End If
End If
Set oldRange = Target
End Sub



Sub Auto_Open()
    Sheets("Sheet1").Range("A1") = "copyright by :"
    Sheets("Sheet1").Range("A2") = "https://baladaka.blogspot.com"

If Sheets("Sheet1").Range("D1") <> "djamaludin" Then
MsgBox "Maaf....Anda telah menghapus / mengganti nama website saya, sehingga file ini akan langsung ditutup", vbInformation, "https://baladaka.blogspot.com"
    ThisWorkbook.Close
    Exit Sub
        
ElseIf Sheets("Sheet1").Range("F1") <> "https://baladaka.blogspot.com" Then
MsgBox "Maaf....Anda telah menghapus / mengganti nama website saya, sehingga file ini akan langsung ditutup", vbInformation, " https://baladaka.blogspot.com"
    ThisWorkbook.Close
    Exit Sub

ElseIf Sheets("Sheet2").Range("A1") <> "Jampang Manggung" Then
MsgBox "Maaf....Anda telah menghapus / mengganti nama website kami, sehingga file ini akan langsung ditutup", vbInformation, "https://baladaka.blogspot.com"
    ThisWorkbook.Close
    Exit Sub
    
End If

End Sub




'Perintah Hapus Data Dengan menampilkan pesan pilihan


Sub HapusData_Click()

  If MsgBox("Apakah anda yakin akan menghapus data ?", vbYesNo, "Hapus Data") = vbNo Then Exit Sub
   Sheets("INPUT").Range("B2:B16").ClearContents
   Sheets("INPUT").Range("D2:D16").ClearContents
   Sheets("INPUT").Range("data").ClearContents

   MsgBox ("Data berhasil dikosongkan"), vbInformation, "https://baladaka.blogspot.com"
   Exit Sub

End Sub





'Perintah Hapus Data tanpa menampilkan pesan pilihan.


Sub HapusData2_Click()

   Sheets("INPUT").Range("N2:O16").ClearContents

   MsgBox ("Data berhasil dikosongkan"), vbInformation, "https://baladaka.blogspot.com"
   Exit Sub

End Sub




Menyembunyikan Sheet pada saat file di tutup


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets("Home").Select

Call Proteksi

End Sub

Sub Proteksi()

Sheets("Sheet1").Visible = xlSheetVeryHidden
Sheets("Sheet2").Visible = xlSheetVeryHidden
Sheets("Sheet3").Visible = xlSheetVeryHidden

End Sub





Menampilkan Sheet pada saat file di buka


Private Sub Workbook_Open()
Sheets("Sheet1").Visible = xlSheetVisible
Sheets("Sheet2").Visible = xlSheetVisible
Sheets("Sheet3").Visible = xlSheetVisible

End Sub


'Menampilkan Pilihan Jenis Printer

Sub JenisPrint()

Application.Dialogs(xlDialogPrinterSetup).Show
End Sub


'Menampilkan Print Preview

Sub PrintPreview()

ActiveSheet.PrintPreview
End Sub


'Print Langsung
  
Sub PrintLangsung()
ActiveSheet.PrintOut
End Sub


'Pilihan print sheet dengan jumlah print
  
Sub PrintBanyak()

  formPrint1.Show
End Sub
  

'Pilihan print sheet tanpa jumlah print
  
Sub PrintBanyak2()

  formPrint2.Show
End Sub


'Print Area Tertentu
Sub cetakareatertentu_Click()

Worksheets("Sheet2").PageSetup.PrintArea = "$B2:$H25"
Worksheets("Sheet2").PrintOut Copies:=1, Collate:=True

End Sub


Private Sub Workbook_Open()

JumlahBuka = GetSetting("baladaka26", "Demo", "JumlahBuka", 0) + 1
If JumlahBuka > 3 Then
    MsgBox "Mohon Maaf Sobat...!!!, Masa Aktif aplikasi ini sudah habis. File akan langsung dihapus permanen." & vbCrLf _
    & "Untuk mendapat Full Version, silahkan " _
    & " konfirmasi melalui SMS", vbCritical, "https://baladaka.blogspot.com"
    	
	With ThisWorkbook
	.Saved = True
	.ChangeFileAccess xlReadOnly
	Kill .FullName
	.Close False
	End With

End If

SaveSetting "baladaka26", "Demo", "JumlahBuka", JumlahBuka

End Sub


Private Sub Workbook_Open()

JumlahBuka = GetSetting("baladaka72", "Demo", "JumlahBuka", 0) + 1
If JumlahBuka > 3 Then
    MsgBox "Mohon Maaf Sobat...!!!, Masa Aktif aplikasi ini sudah habis. File akan segera ditutup." & vbCrLf _
    & "Untuk mendapat Full Version, silahkan " _
    & " konfirmasi melalui SMS", vbCritical, "https://baladaka.blogspot.com"
    Application.DisplayAlerts = False
    Application.Quit
End If

SaveSetting "baladaka72", "Demo", "JumlahBuka", JumlahBuka

End Sub

1. Menempatkan tanggal pada Cell D6

'forms yang digunakan fmdCalender
'Nama Calender nya yaitu Calender1

Option Explicit


Private Sub cmdclose_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    If IsDate(ActiveCell.Value) Then
        Calender1.Value = DateValue(ActiveCell.Value)
    Else
        Calender1.Value = Date
    End If
End Sub

'Perintah Ini untuk menempatkan posisi tanggal pada cell D6

Private Sub Calender1_Click()
          Range("D6").Value = Calender1.Value
          Unload Me
End Sub




2. Menempatkan tanggal pada posisi data tanggal terakhir

'forms yang digunakan formCalender
'Nama Calender nya yaitu Calender2

Option Explicit

Private Sub cmdclose_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    If IsDate(ActiveCell.Value) Then
        Calender2.Value = DateValue(ActiveCell.Value)
    Else
        Calender2.Value = Date
    End If
End Sub


'Perintah Ini untuk menempatkan posisi data tanggal terakhir
Private Sub Calender2_Click()
Dim iRow As Integer
Dim Ws As Worksheet

iRow = ActiveSheet.Cells(Rows.Count, 2) _
  .End(xlUp).Offset(1, 0).Row
    ActiveSheet.Cells(iRow, 2).Value = Me.Calender2.Value

    Calender2.Value = Calender2.Value
    Unload Me

End Sub




3. Menempatkan tanggal pada posisi tanggal pada cell/kursor yang aktif

'forms yang digunakan frmCalender
'Nama Calender nya yaitu Calender3

Option Explicit

Private Sub cmdclose_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    If IsDate(ActiveCell.Value) Then
        Calender3.Value = DateValue(ActiveCell.Value)
    Else
        Calender3.Value = Date
    End If
End Sub

'Perintah Ini untuk menempatkan posisi tanggal pada cell/kursor yang aktif
Private Sub Calender3_Click()
    ActiveCell.Value = Calender3.Value
    Unload Me

End Sub



Sub pindahkan_data()
Worksheets("SPP").Select
Worksheets("SPP").Range("saat_ini").Select

Application.CutCopyMode = False
    Sheets("SPP").Range("saat_ini").Copy
    Sheets("SPP").Range("F14").PasteSpecial xlPasteValues
 
	'Menghapus Data 
 	Sheets("SPP").Range("sekarang").ClearContents

'Menampilkan Pesan
     MsgBox "Data Sudah di Pindahkan... by baladaka.blogspot.com"

End Sub


Sub PindahDataKasUmum()
    Dim terima, keluar As String
    Dim BarisTerakhir, BarisTujuan As Integer
   
    With Worksheets("Kas Umum")
        terima = .Cells(18, 11).Value
        keluar = .Cells(18, 12).Value
   
    End With
    
   'Memindahkan Data
    With Worksheets("Kas Umum")
        BarisTerakhir = .Cells(.Rows.Count, 1).End(xlUp).Row
        BarisTujuan = BarisTerakhir + 1
        .Cells(6, 11).Value = terima
        .Cells(6, 12).Value = keluar

	'Menghapus Data
        Sheets("Kas Umum").Range("B7:B16").ClearContents
        Sheets("Kas Umum").Range("J7:M16").ClearContents

	'Menampilkan Pesan
        MsgBox "Data Sudah di Pindahkan... by https://baladaka.blogspot.com"

    End With
End Sub


'Adapun perintah untuk menampilkan data yang disembunyikan : 

Sub Unfilter_Tampilkan()
    ActiveSheet.Range("$A$16:$A$93" ).AutoFilter Field:=1

End Sub


Sub Filter_Sembunyikan()
    ActiveSheet.Range("$A$16:$A$93" ).AutoFilter Field:=1, Criteria1:="<>"

End Sub

'Adapun perintah untuk menampilkan data yang disembunyikan : 

Sub Unfilter_Tampilkan()
    ActiveSheet.Range("$A$16:$A$93" ).AutoFilter Field:=1

End Sub


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 = "https://baladaka.blogspot.com !!!"
       Exit Function
    End If
    If x < 0 Then
       x = Int(x * -1)
    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 > 1 Then
          baca = baca + ratus(ribu, 2) + "ribu "
       End If
       If ribu = 1 Then
          baca = baca + "seribu "
       End If
       'Baca bagian rupiah dan ditambah akhiran rupiah
       If satu > 0 Then
          baca = baca + ratus(satu, 1)
       End If
       
       'Baca bagian sen dan ditambah akhiran sen
       
       If sen >= 0 Then
          baca = baca & ratus(sen, 0) + ""
       End If


       If x >= 1 Then
          baca = baca + "rupiah "
       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 = "Nihil"
        Case 1: angka = "Satu "
        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 = "Dua belas "
        Case 13: angka = "Tiga belas "
        Case 14: angka = "Empat belas "
        Case 15: angka = "Lima belas "
        Case 16: angka = "Enam belas "
        Case 17: angka = "Tujuh belas "
        Case 18: angka = "Delapan belas "
        Case 19: angka = "Sembilan belas "
    End Select
End Function



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 = "https://baladaka.blogspot.com !!!"
       Exit Function
    End If
    If x < 0 Then
       x = Int(x * -1)
    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 > 1 Then
          baca = baca + ratus(ribu, 2) + "ribu "
       End If
       If ribu = 1 Then
          baca = baca + "seribu "
       End If
       'Baca bagian rupiah dan ditambah akhiran rupiah
       If satu > 0 Then
          baca = baca + ratus(satu, 1)
       End If
       
      'Baca bagian sen dan ditambah akhiran sen
       
       If sen >= 0 Then
          baca = baca & ratus(sen, 0) + ""
       End If


       If x >= 1 Then
          baca = baca + "rupiah "
       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 = "Nihil"
        Case 1: angka = "Satu "
        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 = "Dua belas "
        Case 13: angka = "Tiga belas "
        Case 14: angka = "Empat belas "
        Case 15: angka = "Lima belas "
        Case 16: angka = "Enam belas "
        Case 17: angka = "Tujuh belas "
        Case 18: angka = "Delapan belas "
        Case 19: angka = "Sembilan belas "
    End Select
End Function


Public Function Terbilang(a 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 a > 1000000000000# Then
       Terbilang = "< Silahkan input nilai dibawah satu triliun rupiah >"
       Exit Function
    End If
    'Jika a = 0, maka dibaca 0
    If a = 0 Then
       baca = angka(0, 1)
    Else
       'bilangan triliun, milyar, juta, ribu, rupiah, dan sen
       triliun = Int(a * 0.001 ^ 4)
       milyar = Int((a - triliun * 1000 ^ 4) * 0.001 ^ 3)
       juta = Int((a - triliun * 1000 ^ 4 - milyar * 1000 ^ 3) / 1000 ^ 2)
       ribu = Int((a - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2) / 1000)
       satu = Int(a - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2 - ribu * 1000)
       Sen = Int((a - Int(a)) * 100)
       'membuat bilangan triliun
       If triliun > 0 Then
          baca = ratus(triliun, 5) + "triliun "
       End If
       'membuat bilangan milyar
       If milyar > 0 Then
          baca = ratus(milyar, 4) + "milyar "
       End If
       'membuat bilangan juta
       If juta > 0 Then
          baca = baca + ratus(juta, 3) + "juta "
       End If
       'membuat bilangan ribu
       If ribu > 0 Then
          baca = baca + ratus(ribu, 2) + "ribu "
       End If
       'membuat bilangan rupiah
       If satu > 0 Then
          baca = baca + ratus(satu, 1) + ""
       Else
          baca = baca + ""
       End If
       'membuat bilangan 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(a As Currency, Posisi As Integer) As String
    Dim a100 As Integer, a10 As Integer, a1 As Integer
    Dim baca As String
    a100 = Int(a * 0.01)
    a10 = Int((a - a100 * 100) * 0.1)
    a1 = Int(a - a100 * 100 - a10 * 10)
    'Spesifikasi Ratus
    If a100 = 1 Then
       baca = "Seratus "
    Else
       If a100 > 0 Then
          baca = angka(a100, Posisi) + "ratus "
       End If
    End If
    'Spesifikasi 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(a As Integer, Posisi As Integer)
    Select Case a
        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 = "Dua belas "
        Case 13: angka = "Tiga belas "
        Case 14: angka = "Empat belas "
        Case 15: angka = "Lima belas "
        Case 16: angka = "Enam belas "
        Case 17: angka = "Tujuh belas "
        Case 18: angka = "Delapan belas "
        Case 19: angka = "Sembilan belas "
    End Select
End Function

Demikian Catatan Kecil tentang :
Terima kasih atas kunjungannya dan "Selamat Berkreasi Semoga Sukses"

Labels:
Selanjutnya 
« Prev Post
 Sebelumnya
Next Post »

Catatan Terkait


1 komentar:

  1. AnonimSelasa, Mei 23, 2023 7:57:00 AM

    terima kasih sangat membantu sekali kepada saya yang baru tertarik belajar micro vba. dan mohon share juga kode untuk menghapus foto dalam sheet karena saya coba pakai kode diatas yang terhapus hanya data didalamnya saja sedangkan foto tetap tidak terhapus. trm kasih

    BalasHapus

Silahkan tulis komentar / saran-sarang yang membangun di sini !
Powered by : Blogger
DMCA.com Protection Status
Kode-kode VBA Macro Excel Yang Sering Digunakan