Buat Angsuran pinjaman menurun dengan VBA Excel

Private Sub Ags_AfterUpdate()
If Ags <> "" Then
ListBox1.Clear
Call TampilList
Dim a As Integer
For a = 1 To 12
 With ListBox1
.AddItem
 .List(.ListCount - 1, 0) = a
 .List(.ListCount - 1, 1) = Format(WorksheetFunction.EDate(Now(), (a)), "mmmm yyyy;@")
 .List(.ListCount - 1, 2) = "Rp." & Format(Ags - ((Ags / 12) * (a - 1)), "###,###")
 .List(.ListCount - 1, 3) = "Rp." & Format((Ags - ((Ags / 12) * (a - 1))) * (5 / 100), "###,###")
 .List(.ListCount - 1, 4) = "Rp." & Format(Ags / 12, "###,###")
 .List(.ListCount - 1, 5) = "Rp." & Format(Ags / 12 + (Ags - ((Ags / 12) * (a - 1))) * (5 / 100), "###,###")
 .List(.ListCount - 1, 6) = "Rp." & Format(Ags - ((Ags / 12) * a), "###,###")
  End With
 Next a
 Ags.Value = Format(Ags.Value, "###,###")
 End If
End Sub
Sub TampilList()
With ListBox1
.AddItem
.List(.ListCount - 1, 0) = "Ags." ' Kolom pertama
.List(.ListCount - 1, 1) = "Tanggal" 'Kolom kedua dan seterusnya
.List(.ListCount - 1, 2) = "Saldo"
.List(.ListCount - 1, 3) = "Jasa"
.List(.ListCount - 1, 4) = "Pokok"
.List(.ListCount - 1, 5) = "Jumlah"
.List(.ListCount - 1, 6) = "Saldo"
End With
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
If ListBox1.ListIndex > 0 Then
ListBox1.RemoveItem (ListBox1.ListIndex)
End If
End Sub
Private Sub KELUAR_Click()
TRANSAKSI.TxtPINJ = Format(ANGSURAN.Ags * 1, "#,##0")
Unload Me
End Sub
Private Sub Label36_Click()
ListBox1.Clear
Ags.Value = ""
End Sub

YANG AKU TAKUT

🥀🌻 *YANG AKU TAKUT...*🌻🥀
*_Yang aku takut_*
hatiku kian mengeras dan susah menerima nasihat, namun
*sangat pandai menasihati*.
*_Yang aku takut_*
aku merasa paling benar sehingga
*merendahkan yang lain*.
*_Yang aku takut_*
egoku terlalu tinggi hingga
*merasa paling baik di antara yang lain*.
*_Yang aku takut_*
aku lupa bercermin, namun
*sibuk berprasangka buruk kepada yang lain*.
*_Yang aku takut_*
ilmuku akan membuatku
*menjadi sombong, memandang rendah yang berbeda denganku*.
*_Yang aku takut_*
lidahku makin lincah membicarakan aib saudaraku, namun
*_lupa dengan aibku_*
*_yang menggunung dan tak sanggup kubenahi_*.
*_Yang aku takut_*
aku hanya hebat dalam berkata, namun
*_buruk dalam bertindak_*
*_Yang aku takut_*
aku hanya pintar dalam berdakwah, namun
*_susah untuk mentaati_*
*_Yang aku takut_*
aku hanya cerdas dalam mengkritik,  namun
*_lemah dalam mengintrospeksi diri sendiri_*
*_Yang aku takut_*
aku membenci dosa orang lain namun
*_saat aku sendiri berbuat dosa, aku enggan membencinya_*.
*_Ya Allah ya Rabb* ...
*aku berlindung padaMu*
*dari kelemahanku sendiri*
*Lembutkanlah hatiku*
*dan redam egoku*
*Jauhkan aku*
*dari sifat berbangga diri*,
*hasad*,
*iri dan dengki*.
_*Yaa Allah, yaa Robbi*_
*Sungguh*
*_aku memohon hidayah_*
*_dan ampunanMu_*
*Aamiin Yaa Rabbal 'Aalamiin*....

Angka ke terbilang vba excel

Private Sub CommandButton2_Click()
Dim i As Integer, a As Integer, MyNumber As Integer
For i = 7 To 50
Dim myarray(9) As String
        myarray(0) = " Zero "
        myarray(1) = "One"
        myarray(2) = "Two"
        myarray(3) = "Three"
        myarray(4) = "Four"
        myarray(5) = "Five"
        myarray(6) = "Six"
        myarray(7) = "Seven"
        myarray(8) = "Eight"
        myarray(9) = "Nine"
For a = 1 To Len(Range("B" & i).Value)
tmp = myarray(Mid(Range("B" & i), a, 1))
Range("C" & i) = Range("C" & i) & " " & tmp
Next a
        Next i
End Sub


UserFormya :Private Sub TextBox1_Change()
If TextBox1 <> "" Then
TextBox2 = Len(TextBox1)
Dim myarray(9) As String
        myarray(0) = " Zero "
        myarray(1) = "One"
        myarray(2) = "Two"
        myarray(3) = "Three"
        myarray(4) = "Four"
        myarray(5) = "Five"
        myarray(6) = "Six"
        myarray(7) = "Seven"
        myarray(8) = "Eight"
        myarray(9) = "Nine"
  Dim i As Integer, tmp As String
For i = 1 To Len(TextBox1)
tmp = tmp & " " & myarray(Mid(TextBox1, i, 1))
Next
  TextBox3 = tmp
          End If
End Sub

Singkat kata dengan VBA Excel

Private Sub TextBox1_Change()
Dim i As Integer, tmp As String, kangim() As String
kangim = Split(TextBox1)
For i = LBound(kangim) To UBound(kangim)
tmp = tmp & Mid(kangim(i), 1, 1)
Next
TextBox2 = tmp
End Sub

Kalao menggunakan UDF

Function Singkatan(ref As Range) As String
Dim i As Integer, tmp As String, kangim() As String
kangim = Split(ref)
For i = LBound(kangim) To UBound(kangim)
tmp = tmp & Mid(kangim(i), 1, 1)
Next
Singkatan = tmp
End Function

cara gunakannya
=Singkatan(B1)

Mengatasi ListView1 error lvwReport

dowonload active control 6
https://www.microsoft.com/en-us/download/confirmation.aspx?id=10019

Menggunakan Dua Office Sekaligus Dalam Satu Computer

Untuk menggunakan Dua Office dalam satu Computer, yang paling di butuhkan adalah kode perintah untuk menambahkan settingan di Registri computer kamu, berikut kodenya:
1. Kode untuk office 2003

reg add HKCU\Software\Microsoft\Office\11.0\Word\Options /v NoReReg /t REG_DWORD /d 1

2. Kode untuk office 2007

reg add HKCU\Software\Microsoft\Office\12.0\Word\Options /v NoReReg /t REG_DWORD /d 1

3. Kode untuk office 2010

reg add HKCU\Software\Microsoft\Office\14.0\Word\Options /v NoReReg /t REG_DWORD /d 1

4. Kode untuk office 2013
reg add HKCU\Software\Microsoft\Office\15.0\Word\Options /v NoReReg /t REG_DWORD /d 1

masukkan ke kotak Run

Cek semua TextBox ComboBox CheckBox kosong dengan VBA

Sub Cekdata()
Dim ctr As Control
For Each ctr In Me.Controls
If TypeOf ctr Is MSForms.TextBox Or TypeOf ctr Is MSForms.ComboBox Or TypeOf ctr Is MSForms.CheckBox Then
If ctr = vbNullString Or ctr = False Then
MsgBox ctr.Name & "Masih Kosong"
ctr.SetFocus
Exit Sub
End If
End If
Next ctr
End Sub

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

BUNGKUS DAN ISI

Hidup akan sangat melelahkan, sia-sia dan menjemukan bila pikiran hanya digunakan untuk mencari dan mengurus BUNGKUS-nya saja serta mengabaikan dan mengacuhkan ISI-nya.
Apa itu “BUNGKUS”-nya,
Dan apa itu “ISI”-nya?.

“Rumah yang indah” hanya bungkusnya.
“Keluarga bahagia” itu isinya.

“Pesta pernikahan” hanya bungkusnya.
“Sakinah, mawadah, warahmah” itu isinya.

“Ranjang mewah” hanya bungkusnya.
“Tidur nyenyak” itu isinya.

“Kekayaan” itu hanya bungkusnya.
“Hati yang bahagia” itu isinya.

“Makan enak” hanya bungkusnya.
“Gizi, energi, dan sehat” itu isinya.

“Kecantikan dan Ketampanan” hanya bungkusnya.
“Kepribadian dan hati” itu isinya.

“Bicara” itu hanya bungkusnya.
“Amal nyata” itu isinya.

“Buku” hanya bungkusnya.
“Pengetahuan” itu isinya.

“Jabatan” hanya bungkusnya.
“Pengabdian dan pelayanan” itu isinya.

“Kharisma” hanya bungkusnya.
“Ahlaqul karimah” itu isinya.

“Hidup di dunia” itu bungkusnya.
“Hidup sesudah mati” itu isinya.

Utamakanlah ISI-nya.
Namun rawatlah BUNGKUS-nya.

Jangan memandang rendah dan hina setiap BUNGKUS yang kita terima, karena berkah tak selalu datang dari BUNGKUS kain sutera melainkan juga datang dari BUNGKUS koran bekas.

Janganlah setengah mati mengejar apa yang tak bisa kita bawa mati