Salam master excel, Akhir tahun 2012 saya pernah menanyakan masalah ini ke milis dan sudah ditanggapai temen-temen milis sangat memuaskan, setelah saya mendapat jawaban dari temen-temen milis saya mencoba untuk mengembangkan sesuai apa yang saya butuhkan dengan menggunakan pemahaman saya sendiri. Setelah saya membuat modul VBA dengan pemahaman bahasa saya sendiri, saya mohon masukan para master excel poin-point mana yang bisa diringkas/diefisienkan. Modul saya pindah ke notepad, tadi saya mau kirimkan dengan excelnya ukurannya hampir 700kb jadi saya hanya copykan modulnya saja. Gambarannya setiap sub prosedur saya bikin satu tombol, dan bagaimana jika satu modul yang terdiri dari beberapa sub dibuat 1 tombol. Semoga bahsa saya tidak membingungkan temen temen....
Terimaskih
Option Explicit ' ---------------------------- ' ' Code by Jan Raisin ' ' untuk millis Belajar Excel ' ' 12 November 2012 ' ' ---------------------------- ' ' nama prosedur Sub DistKeSheet() ' deklarasi header Tanggal, range Tanggal, & cell Tanggal ' tipe data adalah range karena yang akan diambil adalah object-nya Dim hdTgl, rgTgl, cTgl As Range ' deklarasi varabel untuk menyimpan nomor baris data ' tipe data adalah long integer (Long) agar dapat memuat nilai yang sangat besar Dim rData, c As Long ' deklarasi variabel untuk menyimpan nama sheet ' tipe data adalah string karena akan digunakan menyimpan data berupa text / string Dim NamaSheet As String ' deklarasi variabel untuk menyimpan saldo akhir ' tipe data adalah dobel untuk mengantisipasi nilai dalam bentuk desimal Dim Saldo As Double Dim rng As Range, lRec As Long '<<<<<<<<< Baru untuk bpp Set rng = Sheet2.Range("c10").CurrentRegion '<<<<<<< baru With rng lRec = .Rows.Count - 1 If lRec > 0 Then With .Resize(lRec, 1).Offset(9, 2) .Formula = "=if(d10="""","""",row()-9)" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 5) .Formula = "=if(d10="""","""",Index(Master!$B$4:$B$46, Match(D10, Master!$C$4:$C$46, 0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 20) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(u$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 21) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(v$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 22) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(w$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 23) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(x$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 24) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(y$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 25) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(z$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 26) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(aa$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 27) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(ab$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(9, 28) .Formula = "=IF(F10="""",0,INDEX(Master!$E$4:$M$46, MATCH(F10,Master!$B$4:$B$46,0), MATCH(ac$7,Master!$E$2:$M$2,0)))" .Parent.Calculate .Value = .Value End With End If End With 'untuk membersihkan sheet Sheets("bku").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Sheets("Tunai").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Sheets("bank").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Sheets("perjadin").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Sheets("lain").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Sheets("kas").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents ' non-aktifkan fitur screen update agar vba berjalan lebih cepat Application.ScreenUpdating = False ' pertama, aktifkan sheet input Sheets("Input").Select ' tentukan lokasi header untuk tanggal ' letaknya di sheet input cell b8 Set hdTgl = Sheets("Input").Range("b8") ' tentukan lokasi range tanggel ' letaknya 1 baris di bawah header ' sampai dengan baris terakhir yang berisi data Set rgTgl = Range(hdTgl.Offset(1, 0), hdTgl.End(xlDown)) ' lakukan loop terhadap range tanggal For Each cTgl In rgTgl ' ambil nilai baris dari setiap tanggal dengan menggunakan perintah .Row rData = cTgl.Row ' lakukan loop untuk kolom J (kolom nomer 10) sampai R (kolom nomer 18) For c = 21 To 26 ' periksa kondisi apakah perpotongan antara baris & kolom bernilai 0 (nol) atau tidak If Cells(rData, c).Value <> 0 Then ' jika perpotongan baris & kolom <> 0 (nol) ' ambil nilai di baris 7 pada kolom tersebut menggunakan perintah .Value ' cara menunjuknya adalah menggunakan perintah Cells(7, c) ' nilai ini adalah nama setiap sheet yang akan menerima distribusi data ' dan disimpan dalam variabel yang bernama NamaSheet NamaSheet = Cells(7, c).Value ' panggil sheet tersebut sesuai dengan namanya Sheets(NamaSheet).Select ' pergi ke cell B10, karena ini adalah header tanggal dari setiap sheet Range("b10").Select ' periksa apakah 1 baris di bawah header tanggal tersebut ada datanya atau tidak If ActiveCell.Offset(1, 0) = "" Then ' jika 1 baris di bawah header tidak ada datanya, maka ' dari header turun 1 baris ke bawah menggunakan perintah .Offset(1, 0) ActiveCell.Offset(1, 0).Select ' karena ini adalah data pertama, maka ' beri nilai 1 pada kolom nomer bukti ' letaknya adalah 1 kolom di sebelah kanan dari cell yang aktif ' untuk menunjuk lokasinya menggunakan perintah .Offset(, 1) 'ActiveCell.Offset(, 1).Value = 1 <<< jk di sheet urut (ada 2 item yanghrs d ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value ' selain itu Else ' kalo sampai di sini, berarti di sheet tersebut sudah ada datanya ' dari header turun ke data yang paling bawah menggunakan perintah .End(xlDown) ' lalu turun lagi 1 baris ke baris yang kosong dengan menggunakan perintah .Offset(1, 0) ActiveCell.End(xlDown).Offset(1, 0).Select ' karena sebelumnya sudah ada data, maka nomer bukti adalah <<<< nomor di sheet ' nomer bukti pada baris di atasnya ditambah dengan nilai 1 'ActiveCell.Offset(, 1).Value = ActiveCell.Offset(-1, 1).Value + 1 <<< jk di sheet urut ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value ' yang ini adalah akhir dari pemeriksaan apakah di sheet yang dituju sudah ada datanya atau belum End If ' mulai dari sini kita akan bekerja dengan cell yang aktif pada sheet yang sudah terpilih ' untuk itu selalu dibuka dengan perintah With nama_object ' dan selalu ditutup dengan End With With ActiveCell ' pada aktif cell diisi dengan tanggal ' nilainya berasal dari sheet Input, terletak pada perpotongan baris dengan kolom 2 (kolom B) .Value = Sheets("Input").Cells(rData, 2).Value ' 2 kolom di sebelah kanan aktif cell diisi dengan nilai yang berasal dari ' perpotongan antara baris dengan kolom (mulai kolom 10 atau kolom J sampai kolom 18 atau kolom R) '.Offset(, 2).Value = Sheets("Input").Cells(rData, c).Value <<< untuk menampilak kolom d,k,d/k ' 2 kolom di sebelah kanan aktif cell diisi dengan Uraian Transaksi ' nilainya berasal dari sheet Input, terletak pada perpotongan baris dengan kolom 4 (kolom d) .Offset(, 2).Value = Sheets("Input").Cells(rData, 5).Value '.Offset(, 2).Value = Sheets("Input").Cells(rData, 7).Value & " - " & Sheets("Input").Cells(rData, 5).Value '.Offset(, 7).Value = Sheets("input").Cells(rData, 10).Value '.Offset(, 8).Value = Sheets("input").Cells(rData, 11).Value '.Offset(, 9).Value = Sheets("input").Cells(rData, 12).Value '.Offset(, 10).Value = Sheets("input").Cells(rData, 13).Value ' sekarang kita melakukan pengujian data terhadap kode yang tercantum dalam kolom nama baris ' dan perpotongan baris tanggal ' kondisi pertama jika kode adalah D/K If Sheets("Input").Cells(rData, c) = "D/K" Then ' maka nilai kolom Masuk & kolom Keluar pada sheet yang terpilih ' diisi dengan nilai yang berasal dari kolom Jumlah pada sheet Input ' untuk menunjuk kolom masuk yang terletak 3 kolom di sebelah kanan cell aktif ' menggunakan perintah .Offset(, 3) .Offset(, 3).Value = Sheets("Input").Cells(rData, 9).Value ' untuk menunjuk kolom masuk yang terletak 4 kolom di sebelah kanan cell aktif ' menggunakan perintah .Offset(, 4) .Offset(, 4).Value = Sheets("Input").Cells(rData, 9).Value ' lakukan pengujian dengan kondisi berikutnya yaitu kode adalah D ElseIf Sheets("Input").Cells(rData, c) = "D" Then ' pada kondisi ini yang diisi dengan nilai adalah kolom Masuk .Offset(, 3).Value = Sheets("Input").Cells(rData, 9).Value ' sedangkan kolom keluar diisi dengan nilai 0 (nol) .Offset(, 4).Value = 0 ' selain itu, berarti kode adalah K Else ' pada kondisi ini kolom Masuk diisi dengan 0 (nol) .Offset(, 3).Value = 0 ' sedangkan kolom Keluar diisi dengan nilai yang berasal dari sheet Input .Offset(, 4).Value = Sheets("Input").Cells(rData, 9).Value ' ini adalah penutup dari pengecekan kode End If ' sekarang dilakukan pengujian untuk menenukan nilai Saldo Akhir ' jika cell aktif ada di baris 11, berarti ini adalah data pertama If ActiveCell.Row = 11 Then ' maka Saldo akhir adalah nilai pada cell g7 + e11 - f11 Saldo = Range("g7").Value + Range("e11").Value - Range("f11").Value ' selain itu, berarti ini bukanlah data pertama Else ' nilai Saldo akhir berasal dari saldo akhir pada 1 baris di atasnya ' letaknya adalah 1 baris di atas cell aktif ' dan 6 kolom di sebelah kanan cell aktif ' untuk menunjuknya digunakan perintah .Offset(-1, 5) ' ditambah nilai pada kolom Masuk ' letaknya 4 kolom di sebelah kanan cell aktif ' untuk menunjuknya digunakan perintah .Offset(, 3) ' dikurangi nilai kolom Keluar ' letaknya 5 kolom di sebelah kanan cell aktif ' untuk menunjuknya digunakan perintah .Offset(, 4) Saldo = .Offset(-1, 5).Value + .Offset(, 3).Value - .Offset(, 4).Value ' ini adalah penutup dari perhitungan Saldo Akhir End If ' pada cell g8 & kolom Saldo diisi dengan nilai Saldo Akhir yang sudah diperoleh sebelumnya Range("g8").Value = Saldo .Offset(, 5).Value = Saldo ' ini adalah penutup dari blok With ActiveCell End With ' ini adalah penutup dari blok pemeriksaan kode transaksi End If ' panggil kembali sheet Input Sheets("Input").Select ' periksa kolom berikutnya Next c ' periksa baris tanggal berikutnya Next cTgl ' aktifkan kembali fitur screen update Application.ScreenUpdating = True ' ini adalah akhir dari prosedur Distribusi ke setiap sheet End Sub Sub BPP() Dim hdTgl, rgTgl, cTgl As Range Dim rData, c As Long Dim NamaSheet As String Dim Saldo As Double Sheets("bpp").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Application.ScreenUpdating = False Sheets("Input").Select Set hdTgl = Sheets("Input").Range("b8") Set rgTgl = Range(hdTgl.Offset(1, 0), hdTgl.End(xlDown)) For Each cTgl In rgTgl rData = cTgl.Row For c = 27 To 27 If Cells(rData, c).Value <> 0 Then NamaSheet = Cells(7, c).Value Sheets(NamaSheet).Select Range("b10").Select If ActiveCell.Offset(1, 0) = "" Then ActiveCell.Offset(1, 0).Select ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value Else ActiveCell.End(xlDown).Offset(1, 0).Select ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value End If With ActiveCell .Value = Sheets("Input").Cells(rData, 2).Value .Offset(, 4).Value = Sheets("Input").Cells(rData, 5).Value .Offset(, 2).Value = Sheets("input").Cells(rData, 7).Value Dim rng As Range, lRec As Long '<<<<<<<<< Baru untuk bpp Set rng = Sheet7.Range("b10").CurrentRegion '<<<<<<< baru With rng lRec = .Rows.Count - 1 If lRec > 0 Then With .Resize(lRec, 1).Offset(1, 3) '.Formula = "=LEFT(f11,FIND("" - "",f11&"" - - "",FIND("" - "",f11&"" - "")+1)-1)" .Formula = "=LEFT(f11,FIND("" _ "",f11&"" _ _ "")-1)" .Parent.Calculate .Value = .Value End With End If End With If Sheets("Input").Cells(rData, c) = "D/K" Then .Offset(, 5).Value = Sheets("Input").Cells(rData, 9).Value .Offset(, 6).Value = Sheets("Input").Cells(rData, 9).Value ElseIf Sheets("Input").Cells(rData, c) = "D" Then .Offset(, 5).Value = Sheets("Input").Cells(rData, 9).Value .Offset(, 6).Value = 0 Else .Offset(, 5).Value = 0 .Offset(, 6).Value = Sheets("Input").Cells(rData, 9).Value End If If ActiveCell.Row = 11 Then Saldo = Range("i7").Value + Range("g11").Value - Range("h11").Value Else Saldo = .Offset(-1, 7).Value + .Offset(, 5).Value - .Offset(, 6).Value End If Range("i8").Value = Saldo .Offset(, 7).Value = Saldo End With End If Sheets("Input").Select Next c Next cTgl Application.ScreenUpdating = True End Sub Sub up() Dim hdTgl, rgTgl, cTgl As Range Dim rData, c As Long Dim NamaSheet As String Dim Saldo As Double Sheets("up").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents 'Sheets("pajak").Select 'Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents 'Range(Range("g8"), Range("g8")).ClearContents Application.ScreenUpdating = False Sheets("Input").Select Set hdTgl = Sheets("Input").Range("b8") Set rgTgl = Range(hdTgl.Offset(1, 0), hdTgl.End(xlDown)) For Each cTgl In rgTgl rData = cTgl.Row For c = 28 To 28 If Cells(rData, c).Value <> 0 Then NamaSheet = Cells(7, c).Value Sheets(NamaSheet).Select Range("b10").Select If ActiveCell.Offset(1, 0) = "" Then ActiveCell.Offset(1, 0).Select ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value Else ActiveCell.End(xlDown).Offset(1, 0).Select ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value End If With ActiveCell .Value = Sheets("Input").Cells(rData, 2).Value .Offset(, 2).Value = Sheets("Input").Cells(rData, 5).Value .Offset(, 7).Value = Sheets("input").Cells(rData, 10).Value .Offset(, 8).Value = Sheets("input").Cells(rData, 11).Value .Offset(, 9).Value = Sheets("input").Cells(rData, 13).Value .Offset(, 10).Value = Sheets("input").Cells(rData, 15).Value .Offset(, 11).Value = Sheets("input").Cells(rData, 17).Value If Sheets("Input").Cells(rData, c) = "D/K" Then .Offset(, 3).Value = Sheets("Input").Cells(rData, 9).Value .Offset(, 4).Value = Sheets("Input").Cells(rData, 9).Value ElseIf Sheets("Input").Cells(rData, c) = "D" Then .Offset(, 3).Value = Sheets("Input").Cells(rData, 9).Value .Offset(, 4).Value = 0 Else .Offset(, 3).Value = 0 .Offset(, 4).Value = Sheets("Input").Cells(rData, 9).Value End If If ActiveCell.Row = 11 Then Saldo = Range("g7").Value + Range("e11").Value - Range("f11").Value Else Saldo = .Offset(-1, 5).Value + .Offset(, 3).Value - .Offset(, 4).Value End If Range("g8").Value = Saldo .Offset(, 5).Value = Saldo End With End If Sheets("Input").Select Next c Next cTgl Application.ScreenUpdating = True End Sub Sub Pajak() Dim hdTgl, rgTgl, cTgl As Range Dim rData, c As Long Dim NamaSheet As String Dim Saldo As Double Sheets("pajak").Select Range(Range("b11"), Range("b11").End(xlDown).End(xlToRight)).ClearContents Range(Range("g8"), Range("g8")).ClearContents Application.ScreenUpdating = False Sheets("Input").Select Set hdTgl = Sheets("Input").Range("b8") Set rgTgl = Range(hdTgl.Offset(1, 0), hdTgl.End(xlDown)) For Each cTgl In rgTgl rData = cTgl.Row For c = 29 To 29 If Cells(rData, c).Value <> 0 Then NamaSheet = Cells(7, c).Value Sheets(NamaSheet).Select Range("b10").Select If ActiveCell.Offset(1, 0) = "" Then ActiveCell.Offset(1, 0).Select ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value Else ActiveCell.End(xlDown).Offset(1, 0).Select ActiveCell.Offset(, 1).Value = Sheets("Input").Cells(rData, 3).Value End If Dim rng As Range, lRec As Long '<<<<<<<<< Baru untuk bpp Set rng = Sheet10.Range("b10").CurrentRegion '<<<<<<< baru With rng lRec = .Rows.Count - 1 If lRec > 0 Then With .Resize(lRec, 1).Offset(1, 8) .Formula = "=IF(""PPh 21""=VLOOKUP(C11,Input!$C$10:$AC$2494,6,FALSE),E11-F11,0)" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(1, 9) .Formula = "=IF(""PPh 22""=VLOOKUP(C11,Input!$C$10:$AC$2494,6,FALSE),E11-F11,0)" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(1, 10) .Formula = "=IF(""PPh 23""=VLOOKUP(C11,Input!$C$10:$AC$2494,6,FALSE),E11-F11,0)" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(1, 11) .Formula = "=IF(""PPN""=VLOOKUP(C11,Input!$C$10:$AC$2494,6,FALSE),E11-F11,0)" .Parent.Calculate .Value = .Value End With With .Resize(lRec, 1).Offset(1, 12) .Formula = "=IF(""PPh Ps 4 ayt 2""=VLOOKUP(C11,Input!$C$10:$AC$2494,6,FALSE),E11-F11,0)" .Parent.Calculate .Value = .Value End With End If End With With ActiveCell .Value = Sheets("Input").Cells(rData, 2).Value .Offset(, 2).Value = Sheets("Input").Cells(rData, 5).Value '.Offset(, 8).Value = Sheets("input").Cells(rData, 10).Value '.Offset(, 9).Value = Sheets("input").Cells(rData, 11).Value '.Offset(, 10).Value = Sheets("input").Cells(rData, 13).Value '.Offset(, 11).Value = Sheets("input").Cells(rData, 15).Value '.Offset(, 12).Value = Sheets("input").Cells(rData, 17).Value If Sheets("Input").Cells(rData, c) = "D/K" Then .Offset(, 3).Value = Sheets("Input").Cells(rData, 9).Value .Offset(, 4).Value = Sheets("Input").Cells(rData, 9).Value ElseIf Sheets("Input").Cells(rData, c) = "D" Then .Offset(, 3).Value = Sheets("Input").Cells(rData, 9).Value .Offset(, 4).Value = 0 Else .Offset(, 3).Value = 0 .Offset(, 4).Value = Sheets("Input").Cells(rData, 9).Value End If If ActiveCell.Row = 11 Then Saldo = Range("g7").Value + Range("e11").Value - Range("f11").Value Else Saldo = .Offset(-1, 5).Value + .Offset(, 3).Value - .Offset(, 4).Value End If Range("g8").Value = Saldo .Offset(, 5).Value = Saldo End With End If Sheets("Input").Select Next c Next cTgl Application.ScreenUpdating = True End Sub