Topik ini sudah di-repost berulang kali tapi belum ada yang respon.
gini aja, sambil menunggu BeExceller menyusun solusi topik ini, mungkin mau
sedikit repot mencoba prosedur imajinasi terlampir.
Peringatan!!!
-> Tidak dijamin bakal sukses tanpa error.
Moga-moga ada BeExceller yang bersedia mencobanya (bila perlu
memperbaikinya kalau error) terus di posting kemilis workbooknya.
Bismillah, moga-moga gak error-error banget
1. Syarat yang harus dipenuhi (siapkan dengan baik)
>> gunakan file lampiran dari penanya, jangan diubah sedikit pun [harus
masih ting-ting]
(bila perlu unduh ulang dulu : ada sheet data dan sheet hasil)
>> buka file dari penanya dan lakukan save as dengan cara :
tekan ALT F A -> pada bagian save as type, pilih .xlsm atau
.xlsb -> ganti namanya bila perlu -> tekan tombol Save
>> unduh text file terlampir.
2. cara pasang text file terlampir ke workbook kerja
>> buka workbook hasil proses 1 (kalau belum terbuka)
>> ke VBE (tekan ALT F11) -> menu Insert -> pilih Module
>> buka text file terlampir dengan NotePad atau semacamnya dan jangan diset
Word Wrap
>> copy semua yang ada dalam text file yang terbuka (CTRL A lalu CTRL C)
>> ke VBE lagi, dilembar module baru tadi, lakukan paste (CTRL V)
>> cek baris paling atas, kalau ada baris tulisan option explicit 2 baris,
hapus salah satu barisnya
>> kembali ke worksheet (tekan ALT F11)
>> save workbook (harus tipe .xlsm atau .xlsb ya)
3. buat tombolnya
>> di sheet data, insert sebuah shape
>> klik kanan shape baru itu -> pilih Assign Macro -> pilih UpdateReport ->
tekan OK
>> save workbook lagi
4. coba pencet si shape hasil langkah nomor 3 tadi.
Insya Allah begitu bisa pakai VBA lagi, saya usahakan posting workbook-nya
kalau belum ada BeExceller yang mau mencobanya.
Kalau ada error, kabarkan ke milis ya, supaya banyak yang bisa sempat
ngecek.
Selamat mencoba, dan mohon maaf kalau masih ndak bisa urun yang lebih baik.
Wassalam,
Kid.
2013/4/29 Imam Sinurat <[email protected]>
> **
>
>
> Salam be-excel..
>
> Yth. para suhu dan rekan2 exceler....
> Mohon bantuan pencerahan tentang cara men-Sorting Data Gabungan
> Menggunakan Makro.
>
> Keterangan tabel soalnya sbb:
>
> 1. Semua "nama yang bersifat unik" di-sort sesuai kolom (5) secara
> descending.
>
> 2. Setiap nama yang sama lalu disusun berkelompok sesuai urutan "nama
> unik" tadi, dan masing-masing kelompok nama di-sort kembali sesuai kolom
> (5) secara descending.
>
> 3. Hasil sorting untuk record yang kolom (5) -nya bernilai <=10
> diletakkan pada tabel di deretan atas, sedangkan sisanya di deretan bawah.
>
> 4. Kolom (3) dan (4) digabungkan dan ditampilkan sekolom (seolah-olah ada
> penambahan record).
>
> Bantuannya dimohonkan sangat, terima kasih sebelumnya.
>
> Wassalam
> Imam Sinurat - Sumut
>
>
>
option explicit
'Kid, Jakarta, 2013-04-30
'bagian pembuat sheet temporary, bisa jadi jumlah kolom bantunya kurang, nanti
dimodifikasi sendiri ya
private sub BuildTempTable(rngTarget As Range) 'supaya jelas posisi paste
values hasilnya, dimintalah inputan lokasi cell nama pertama
dim shtTmp as Worksheet, shtRes as Worksheet
dim lRows as Long
err.clear
on error resume next
application.displayalerts = FALSE
set shtTmp = sheets("_bridge_")
if err.number = 0 then
shtTmp.delete
endif
set shtTmp = sheets.add(after:=sheets(sheets.count))
with shtTmp
.name = "_bridge_"
'penulis nama kolom (11 kolom diisi 11 elemen array)
'-> nama kolomnya nanti dipake di pivot table, jadi pastikan
pengubahannya disertai cek seluruh proses buat pivot table
'-> sepertinya pivot table harus case sensitive
.range("a1").resize(1, 11).value = _
array("ONo", "ONama", "ONom1", "ONom2", "OBln", "HJns", "HUrut",
"HMax", "Nama", "Nominal", "BulanTagih")
if GetData then '1. ambil data dulu (sekalian cek ada hasil ambilnya
gak -> butuh function)
CreatePvtMax 'buat pivot nilai max per nama dulu
.pivottables("_pvtMax_").tablerange2.name = "_myPvtMax_" 'area
pivot tablenya diberi nama range untuk formula data source
KomputasiDataSource 'susun data source yang lengkap
CreatePvtRes 'buat pivot hasil
'copas bagian pivot yang jadi hasil akhir ke target
.pivottables("_pvtRes_").tablerange2.offset(1, 4).copy
rngTarget.pastespecial xlpastevalues
endif
end with
'clear temporary
shtTmp.delete
thisworkbook.names("_myBridge_").delete
thisworkbook.names("_myPvtMax_").delete
application.displayalerts = TRUE
err.clear
on error goto 0
end sub
'bagian ambil data baru
private function GetData() As Long
dim rngData as Range, rngBridge as Range
dim lRec as Long, lRows as Long
set rngBridge = sheets("_bridge_").range("a1")
rngBridge.currentRegion.offset(1).clearcontents
rngBridge.currentRegion.resize(2).name = "_myBridge_"
lRows = 1
set rngData = sheets("Data").range("b8").currentregion
with rngData
.parent.autofiltermode = FALSE
'Nom1 -> jenis 1, urut 2 (sorted desc) :: filter Nom1 > 0, sort Nom1
desc
.sort .resize(1).cells(1, 3), xldescending, header:=xlyes,
orientation:=xlsortcolumns 'mungkin column bukan columns tapi column
.autofilter 3, "<>0"
lRec = .resize(, 1).specialcells(xlcelltypevisible).count - 1
if lRec > 0 then
.offset(1).specialcells(xlcelltypevisible).copy
with rngBridge
.offset(lRows).pastespecial xlpastevalues
.offset(lRows, 5).resize(lRec, 1).value = 1
.offset(lRows, 6).resize(lRec, 1).value = 2
lRows = .currentregion.rows.count
end with
endif
'Nom2 -> jenis [formula], urut [formula] :: filter nom2 > 0, sort
nom2 desc
.parent.autofiltermode = FALSE
.sort .resize(1).cells(1, 4), xldescending, header:=xlyes,
orientation:=xlsortcolumns 'mungkin column bukan columns tapi column
.autofilter 4, ">0"
lRec = .resize(, 1).specialcells(xlcelltypevisible).count - 1
if lRec > 0 then
.offset(1).specialcells(xlcelltypevisible).copy
with rngBridge
.offset(lRows).pastespecial xlpastevalues
With .offset(lRows, 5).resize(lRec, 2)
.formular1c1 = "=1*(RC5<=10)" 'penentu HJns
untuk Nom2 yang >0
.parent.calculate
.value = .value
End With
lRows = .currentregion.rows.count
end with
endif
.parent.autofiltermode = FALSE
end with
'buat nama range (update kalau sudah ada)
'sengaja diletakkan disini supaya tampak alur prosesnya
'bagian ini sebenarnya bisa diletakkan dalam blok with rngBridge ... end
with setelah lRows=
if lRows > 1 then
rngBridge.currentregion.name = "_myBridge_"
else
rngBridge.currentregion.resize(2).name = "_myBridge_"
endif
GetData = lRows - 1
end function
'setelah data masuk, buat pivot table penentu nilai max bulan setiap nama
private sub CreatePvtMax()
dim pvtTbl as PivotTable, pvtCache as PivotCache
'create cache (sengaja dibuat bertahap supaya mudah dipelajari dan
dikembangkan)
set pvtCache = thisworkbook.pivotcaches.create(xldatabase, "_myBridge_")
with pvtCache
.refreshonfileopen = TRUE
.missingitemslimit = xlmissingitemsnone
end with
'buat pivot table dari pivotcache yang ada
'asumsi, ada proses untuk ambil pivot cache dan disimpan dalam variabel
pvtCache
set pvtTbl = pvtCache.createpivottable(sheets("_bridge_").range("p1"),
"_pvtMax_")
with pvtTbl
.refreshtable 'refresh :: biasanya sudah
otomatis ter-refresh, jadi bisa di-non aktofkan kayanya
'pivot options
.savedata = FALSE
.rowgrand = FALSE
.columngrand = FALSE
'atur layout
.rowaxislayout xltabularrow 'khusus xl2007 ke atas (non
aktifkan jika di xl2003)
.addfields array("ONama", "HJns") 'sisi row (tambah fields)
.adddatafield .pivotfields("OBln"), "MaxBln", xlmax 'sisi values
(add) dengan field OBln, agregate Max, nama MaxBln
.pivotfields("HJns").pivotfilters.add xlcaptionisgreaterthan, Value1:=0
'filter label HJns >0 :: cek lagi xlcaptionnya kalau error
end with
end sub
'melengkapi data source (nyusun max per nama, tulisan nama untuk tampilan,
nilai nominal tampilan, nilai bulan untuk tampilan)
private sub KomputasiDataSource()
dim rngData as Range
dim lRec as Long
set rngData = sheets("_bridge_").range("a1").currentregion
lRec = rngData.rows.count - 1
if lRec < 1 then
exit sub
endif
set rngData = rngData.resize(lRec, 1).offset(1, 7)
with rngData
'formula untuk kolom-kolom tampilan, cek lagi, sapa tahu salah
ambil kolom. Asumsi record mulai A2
.formula = "=vlookup( b2, _myPvtMax_ ,3,0)*f2" 'ambil nilai max
dari pivot table, khusus data yang bln<=10 -> HJns=1
.offset(0, 1).formula = "=b2&if(g2=1,""*"","""")" 'nama diberi *
kalau HUrut=1 (data Nom2) -> HUrut=2 adalah data Nom1
.offset(0, 2).formula = "=if(g2=2,c2,d2)" 'nilai nominal ambil
Nom1 kalau HUrut=2, ambil Nom2 kalau HUrut selain 2
.offset(0, 3).formula = "=right("" ""&e2&if(g2=1,""*"","" ""),3)"
'membuat selalu 3 karakter bln, ada * kalau HUrut=1
.parent.calculate 'kalkulasi
'divalues
.resize(, 4).copy
.resize(, 4).pastespecial xlpastevalues
end with
end sub
'setelah data source lengkap, susun pivot table hasil akhir
private sub CreatePvtRes()
dim pvtCache as PivotCache, pvtTbl as PivotTable, pvtField as PivotField
'ambil pivot cache dari pivot yang ada di sheet bridge bernama pvtmax
set pvtCache = sheets("_bridge_").pivottables("_pvtMax_").pivotcache
'buat pivot table baru dari pivot cache tersebut (irit memori)
set pvtTbl = pvtCache.createpivottable(sheets("_bridge_").range("w1"),
"_pvtRes_")
with pvtTbl
.refreshtable 'refresh :: kalo ini harus direfresh lagi,
karena data source sudah berubah nilai akibat formula terakhir
'pivot options
.savedata = FALSE
.rowgrand = FALSE
.columngrand = FALSE
'atur layout
.rowaxislayout xltabularrow 'khusus xl2007 ke atas (non
aktifkan jika di xl2003)
.addfields array("HMax", "ONama", "OBln", "HUrut", "Nama", "Nominal",
"BulanTagih") 'semua masuk bagian rows
'hide subtotal di semua field
for each pvtField in .rowfields 'kalau error, ganti dengan
.pivotfields
pvtField.subtotals(1) = TRUE 'buat hanya item pertama yang
ada subtotal (lainnya false)
pvtField.subtotals(1) = FALSE 'buat subtotal item pertama
jadi false juga
next pvtField
'sort descending pivot table berdasar kolom pembentuk output
'kayanya case sensitive, jadi hati-hati, mending copas nama
field
.pivotfields("HMax").autoSort xldescending, "HMax"
.pivotfields("OBln").autoSort xldescending, "OBln"
.pivotfields("HUrut").autoSort xldescending, "HUrut"
end with
end sub
'urusan beresin tampilan hasil akhir di sheet target dimasukkan ke prosedur
yang dipanggil saja
'bagian prosedur yang menjalankan semua prosedur proses di atas.
public sub UpdateReport()
dim rngRes as Range, lRec as Long
set rngRes = sheets("hasil").range("a7")
with rngRes
.currentRegion.offset(1).clearcontents
BuildTempTable .offset(1, 1) 'bangun temporary sekalian
kirim info lokasi target nama pertama di sheet hasil
'pasang nomor
lRec = .currentregion.rows.count - 1
if lRec > 0 then
.offset(1).resize(lRec, 1).formula = "=row()-" & .row
'susun nomor urut pakai formula
.parent.calculate
.offset(1).resize(lRec, 1).value = .offset(1).resize(lRec, 1).value
endif
end with
err.clear
on error goto 0
end sub
