mbak Jan,
izin untuk sedikit mengutak-atik script dari mbak Jan ya, agar script
tersebut dapat berjalan dengan baik di dua buah file dari mr Kid
Option Explicit
' --------------------------- '
' Code by: Miss Jan Raisin '
' untuk millis Belajar Excel '
' 21 November 2012 '
' Re-coded by: Aji Mumpung '
' 21 November 2012 '
' --------------------------- '
' ini adalah nama prosedurnya
Sub RekapData()
' deklarasikan variabel bertipe Range untuk menyimpan objek berupa range
' rgData = range_Data, letaknya di sheet Nota mulai cell H13 samapai
cell H17
' cData = cell_Data, adalah setiap 1 cell di dalam rgData
Dim rgData, cData As Range
' deklarasikan variabel untuk menyimpan nomer baris dengan tipe Long
' r = nomor baris data pertama di sheet Rekap yaitu baris 7 sampai
dengan nomer baris terakhir yang ada datanya
' data tersebut bisa berupa Null String, atau sebut saja yang nanya
bikin semacam acara Jebakan Betmen
' Brs = nomor baris terakhir yang digunakan, letaknya antah berantah
' idxBrs = nomor baris di bawah data yang masih kosong atau Null String
Dim r, Brs, idxBrs As Long
' non-aktifkan aplikasi screen update untuk mempercepat kerja macro
Application.ScreenUpdating = False
' aktifkan sheet Nota, hal ini untuk berjaga-jaga jika sheet aktif
bukanlah sheet Nota
Sheets("Nota").Select
' tetapkan lokasi rgData, yaitu di sheet Nota >> sudah dipanggil
sebelumnya
' letaknya di cell H13 sampai dengan cell H17
Set rgData = Range("h13:h17")
' untuk setiap 1 cell (cData) di dalam rgData
For Each cData In rgData
' jika nilai cData <> "" maka
If cData.Value <> "" Then
' range cData sampai 8 kolom di sebelah kanan cData dicopy
' untuk menunjuk 8 kolom disebelah kanan cData digunakan
perintah cData.Offset(0, 8)
' untuk melakukan copy digunakan perintah .Copy
Range(cData, cData.Offset(0, 8)).Copy
' panggil / aktifkan sheet Rekap
Sheets("Rekap").Select
' panggil / pergi ke cell A7
Range("a7").Select
' saat ini cell aktif berada di cell A7
' pada cell aktif cek apakah ada datanya atau tidak
' jika pada aktif cell ada datanya, maka
If ActiveCell.Value <> "" Then
' hitung nilai baris paling akhir yang berisi data
' bisa saja berupa Null String yang letaknya di antah
berantah
' untuk mengetahui letak cell digunakan perintah
.SpecialCells(xlCellTypeLastCell)
' untuk mengetahui nomer barisnya digunakan perintah .Row
' lalu nomer baris tersebut disimpan dalam sebuah variabel
bernama Brs
Brs = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
' jika nilai Brs lebih besar dari 7
' kenapa harus 7? karena TS meminta data pertama berada di
cell A7 (kolom A, baris 7)
' jika Brs lebih besar dari 7, maka
'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
' penambahan logika untuk seleksi dari :
'
' If Brs > 7 Then
'
' menjadi :
'
If Brs > 7 And Cells(Brs, 1).Value = "" Then
'
' tujuannya adalah untuk mengecek apakah pada kolom A baris
tersebut '
' ada datanya atau tidak
'
'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
' lakukan loop mulai dari baris 7 sampai dengan nomer
baris yang disimpan dalam variabel Brs
For r = 7 To Brs
' lalukan pengecekan kondisi, apakah di baris
tersebut pada kolom 1 ada datanya atau tidak
' untuk menunjukknya menggunakan perintah Cells(r,
1)
' syntaxnya adalah Cells(nomer_baris , nomer_kolom)
' jika pada baris tersebut pada kolom 1 tidak ada
datanya atau Null Sring, maka
If Cells(r, 1).Value = "" Then
' ambil nilai berisnya menggunakan perintah .Row
' lalu disimpan dalam variabel bernama idxBrs
idxBrs = Cells(r, 1).Row
' jika sudah ketemu, lalu keluar dari loop
Exit For
' ini adalah akhir dari pengecekan data pada sheet
Rekap
End If
' jika belum ketemu cell dengan data yang kosong, maka
lanjutkan dengan baris berikutnya
Next r
' ini adalah akhir pengecekan jika nilai Brs lebih besar
dari 7
End If
'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
' penambahan script untuk pengujian kondisi nilai baris
'
' jika nilai idxBrs = 0, karena tidak memenuhi kriteria
pengujian di atas '
' maka nilai idxBrs yang merupakan baris penulisan data
berikutnya adalah '
' nilai Brs ditambah 1
'
' nilai Brs adalah nilai baris dari data yang terakhir
'
If idxBrs = 0 Then
'
idxBrs = Brs + 1
'
End If
'
'
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
' panggil cell yang terpilih
' yaitu nomer baris sesuai nilai yang didapat dalam idxBrs
dan kolom 1
Cells(idxBrs, 1).Select
' ini adalah akhir pengecekan apakah cell A7 di sheet Rekap ada
datanya atau tidak
End If
' pada aktif cell sesuai dengan pengecekan beberapa kondisi di
atas
' dilakukan paste special sesuai dengan nilai dan format data
asal
ActiveCell.PasteSpecial (xlPasteValuesAndNumberFormats)
' setelah itu matikan aplikasi copy paste
Application.CutCopyMode = False
' yang ini adalah akhir dari pemeriksaan apakah cData ada datanya
atau tidak
End If
' panggil kembali sheet Nota, karena saat ini yang aktif adalah
sheet Rekap
Sheets("Nota").Select
' lanjutkan untuk setiap cData berikutnya
Next cData
' aktifkan aplikasi screen update
Application.ScreenUpdating = True
' yang ini adalah akhir dari prosedur
End Sub
Yang diberi warna merah adalah penambahan dan peng-edit-an yang saya
lakukan. Insya Allah sekarang script tersebut dapat berjalan dengan baik di
kedua file, sebelumnya sudah dilakukan uji coba terhadap kedua file
tersebut.
Wassalam,
-Aji Mumpung-
Pada 21 November 2012 16:14, Jan Raisin <miss.jan.rai...@gmail.com> menulis:
> **
>
>
> Dear Be Exceler,
>
> maaf, ternyata script dari Jan yang tadi hanya berjalan dengan baik di
> file Sample.xls, jika ada waktu senggang nanti akan coba Jan perbaiki agar
> dapat berjalan di kedua file, jika ada Be-Exceler yang ingin memperbaiki
> script dari Jan, Jan mempersilakan dengan senang hati :)
>
> Best Regard,
>
> Jan Raisin
>
> Pada 21 November 2012 15:34, Jan Raisin <miss.jan.rai...@gmail.com>menulis:
>
>
>>
