ComboBox untuk tanggal bulan bulan tahun sekarang

Private Sub UserForm_Activate()
 Dim i As Integer
        For i = 1 To 12
            ComboBox1.AddItem (Format(DateAdd("d", (i - 1), Now()), "[$-21]dd mmmm yyyy;@"))
            ComboBox2.AddItem (Format(DateAdd("d", (i - 1), Now()), "[$-21]dd;@"))
            ComboBox3.AddItem (Format(DateAdd("m", i, Now()), "[$-21]mmmm;@"))
            ComboBox4.AddItem (Format(DateAdd("m", -1 + (i - 1) * 12, Now()), "[$-21]yyyy;@"))
        Next i
End Sub

Memasukan Data Textbox ke ListView dengan Tombol pada UserForm

Private Sub CmdTambahListviuw_Click()
Dim lvwItem As ListItem
With ListView1
Set lvwItem = .ListItems.Add(, , TextBox1.Value)
lvwItem.SubItems(1) = TextBox2.Value
lvwItem.SubItems(2) = TextBox3.Value
End With
End Sub

Dan untuk nampilkan semua data dalam ListView

Private Sub UserForm_Activate()
Dim wksSource As Worksheet
Dim rngData As Range
Dim rngCell As Range
Dim LstItem As ListItem
Dim RowCount As Long
Dim ColCount As Long
Dim i As Long
Dim j As Long

Set wksSource = Worksheets("Sheet1")
Set rngData = wksSource.Range("A1").CurrentRegion

For Each rngCell In rngData.Rows(1).Cells
Me.ListView1.ColumnHeaders.Add Text:=rngCell.Value, Width:=90
Next rngCell

RowCount = rngData.Rows.Count
ColCount = rngData.Columns.Count

For i = 2 To RowCount
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value)
For j = 2 To ColCount
LstItem.ListSubItems.Add Text:=rngData(i, j).Value
Next j
Next i
End Sub

Memisahkan Duplikat dan data Unik dengan VBA Excel

Private Sub CommandButton1_Click()
i = 1
J = 0
k = 0
With ThisWorkbook.Sheets("Sheet2")
.[C:C,D:D,E:E].ClearContents
Do
If Application.WorksheetFunction.CountIf(.[C:C], .Cells(i, 1).Value) Then
J = J + 1
.Cells(J, 5).Value = .Cells(i, 1).Value
Else
k = k + 1
.Cells(k, 3).Value = .Cells(i, 1).Value
.Cells(k, 4).Value = Application.WorksheetFunction.CountIf(.[A:A], .Cells(k, 3).Value)
End If
i = i + 1
If .Cells(i, 1).Value = Empty Then Exit Do
Loop
End With
End Sub

Buat No urut diantara dua kolom dengna VBA ( UDF )

Taroh kode dibawah ini pada Modul

Public Function DesiredFunction(first As Integer, last As Integer)
Dim i As Integer

If first > last Then
DesiredFunction = "Error!"
End If

For i = first To last
If i = first Then
DesiredFunction = i
Else
DesiredFunction = DesiredFunction & "," & i
End If
Next i
End Function

Terbilang dengan Rupiah ( UDF VBA Excel )

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 = "< di atas satu triliun 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, 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

Menghapus Check Box pada vba excel di Form

Sub HapusCheckBox()
Dim Ctrl As Control
         For Each Ctrl In Me.Controls
       If TypeOf Ctrl Is MSForms.CheckBox Then: Ctrl.Value = False
      Next Ctrl
End Sub