Hai Ivan,
Sesuaikan dengan keadaan workbook setempat, karena bahasan berikut hanya
berasal dari script yang ada...
Idenya adalah menyusun urutan kolom di sumber menjadi sama dengan yang
dibutuhkan oleh target
A. Dari bagian :
For i = 1 To rng.Rows.Count
Set cell = rng.Cells(i, 1)
If cell.Value <> "" Then
targetCell.Value = CODE
targetCell.Offset(0, 1).Value = cell.Value
targetCell.Offset(0, 2).Value = NAMA
targetCell.Offset(0, 3).Value = cell.Offset(0, 1).Value
targetCell.Offset(0, 4).Value = cell.Offset(0, 4).Value
targetCell.Offset(0, 5).Value = cell.Offset(0, 5).Value
targetCell.Offset(0, 7).Value = TANGGAL
Set targetCell = targetCell.Offset(1, 0)
End If
Next i
> sisi Target
target memiliki urutan kolom (dari kolom A di sheet target) :
1. code,
2. kode (dari kolom A sumber),
3. nama,
4. teks (dari kolom B sumber),
5. nilai (dari E sumber),
6. nilai (dari F sumber),
7. sesuatu (dikosongkan)
8. tanggal
Andaikan kolom ke-3 (nama) diletakkan tepat setelah kolom ke-1 (code),
sepertinya akan lebih pas, sehingga kode (kolom ke-2) tidak terpisah dari
teks tentang si kode (kolom ke-4).
btw, tetap seperti aslinya saja.
> sisi Sumber
sumber memiliki kolom berikut (dari kolom A sheet sumber) :
1. kode (untuk kolom ke-2 target)
2. teks (untuk kolom ke-4 target)
3. tidak tahu 1 [kolom C sumber] (tidak diambil, alias bisa di-hide saat
akan copy)
4. tidak tahu 2 [kolom D sumber] (tidak diambil, alias bisa di-hide saat
akan copy)
5. nilai (untuk kolom ke-5 target)
6. nilai (untuk kolom ke-6 target
B. dari bagian :
A = Range("I1").Value
B = Range("I2").Value
berarti ada nilai awal di A dan nilai akhir di B dengan asumsi, selalu
berlaku A<=B
C. dari bagian :
If lembar_ke = 1 Then
Set rng = .Range("A6:A21")
CODE = .Range("E1").Value
TANGGAL = .Range("G1").Value
NAMA = .Range("B1").Value
maka disimpulkan bahwa setiap baris di .Range("A6:A21") adalah milik
kelompok 1.
nilai Code (kolom ke-1 hasil) diambil dari Range("E1") untuk kelompok 1
begitu pula untuk tanggal dan nama.
Jadi, kira-kira mengubahnya begini : (urut dari kolom terkiri)
1. dibutuhkan 1 kolom untuk nomor kelompok (misal diletakkan di sebelum
tabel), diisi formula
2. dibutuhkan 1 kolom untuk Code diisi formula merujuk ke range di E sesuai
kelompoknya
3. kolom ke-1 sumber (berarti dari asalnya di kolom A, sudah pindah ke C
karena 2 kolom tambahan di atas)
4. dibutuhkan 1 kolom untuk Nama diisi formula merujuk ke range B sesuai
kelompoknya
5,6,7 kolom ke-2,3,4 sumber yang sudah bergeser menjadi di kolom E,F,G
dengan kolom F dan G tidak diambil
8,9 adalah 2 kolom nilai dari sumber (untuk kolom ke-5 dan 6 target) di
kolom H dan i
>> misalkan sheet sumber awalnya memiliki 10 kolom, dan baru digunakan 6
kolom, maka kolom berikutnya adalah
10,11,12,13 adalah 4 kolom sisa (J,K,L,M) milik sumber yang tidak diambil
(10 kolom sumber - baru dipakai 6 kolom = 4 kolom asli sisanya)
14. dibutuhkan 1 kolom untuk sesuatu yang kosong di target kolom ke-7
15. dibutuhkan 1 kolom untuk Tanggal berisi formula yang merujuk ke range G
sesuai kelompoknya.
Misalkan sudah ada header tabel asli di sheet sumber pada baris ke-5,
maka dilakukan hal berikut :
1. insert 2 kolom pada kolom A sheet sumber untuk wadah kolom nomor 1 dan
2, dan beri header Kelompok dan Code. Kolom asli yang tadinya di A sudah
bergeser ke C.
2. klik kolom D dan insert 1 kolom untuk wadah kolom nomor 4 (Nama) dan
header diberi teks berbunyi Nama. Kolom yang tadinya di D akibat proses 1
akan bergeser ke E
3. kolom sumber yang sudah ada di J,K,L,M (bagian dari asumsi 10 kolom
asli milik sumber) dibiarkan apa adanya. Jika tidak ada headernya, maka
beri header berupa beberapa spasi disetiap kolom yang tak ber header
4. kolom N diberi header bernama Kosong
5. kolom O diberi header Tanggal dan diisi formula merujuk ke cell tertentu
berisi tanggal di kelompok itu.
6. Pastikan kolom P kosong
Penyusunan formula di kolom-kolom tambahan : (header di baris ke-5, berari
baris data mulai baris 6
> kolom ke-1 bernama Kelompok (cell A6), berdasar isi C (yang tadinya di A)
=if( c6<>"" , 1 , 0 ) --> 1 adalah nomor kelompok untuk area data
.Range("A6:A21")
copy ke baris data selanjutnya di kelompok 1
> kolom ke-2 bernama Code (cell B6), berdasar isi C (yang tadinya di A)
=if( c6<>"" , $h$1 , "" ) --> $h$1 dari CODE = .Range("E1").Value dengan
E bergeser ke kanan 3 kolom menjadi H
copy ke baris data selanjutnya di kelompok 1, kalau formula di-copy ke
kelompok lain (misal kelompok 2), sesuaikan rujukan $h$*?*
> kolom ke-4 bernama Nama (cell D6) [cell C6 asli dari sumber dan tidak
perlu diubah]
=if( c6<>"", $e$1 , "" ) --> $e$1 dari NAMA = .Range("B1").Value dengan B
bergeser ke kanan 3 kolom menjadi E
copy ke baris data selanjutnya di kelompok 1, kalau formula di-copy ke
kelompok lain (misal kelompok 2), sesuaikan rujukan $e$*?*
> kolom O untuk tanggal :
=if( c6<>"",$J$1 , 0 ) --> $J$1 dari TANGGAL = .Range("G1").Value dengan
G bergeser ke kanan 3 kolom menjadi J
copy ke baris data selanjutnya di kelompok 1, kalau formula di-copy ke
kelompok lain (misal kelompok 2), sesuaikan rujukan $J$*?*
Misalkan ada banyak kelompok yang akhirnya membentuk area data dari baris 5
sampai baris 123456, berarti data di A5:O123456
Area yang di-copy ke target adalah B5:O123456 yang tampak saja.
>> Kelompok yang akan di salin berdasar
A = Range("I1").Value
B = Range("I2").Value
dan telah bergeser 3 kolom menjadi kolom L, yaitu nilai awal di L1 dan
nilai akhir di L2
***** asumsi selalu A<=B *****
Kode VBA : (dalam 1 buah prosedur sub ber-scope public)
dim lAwal as long, lAkhir as long
dim rngData as range, rngCopy as range,rngTarget as range
dim wbkApp as workbook, wbkTarget as workbook
application.screenupdating=false
application.calculation=xlCalculationAutomatic
set wbkapp=thisworkbook
'cek workbook target
on error resume next
set wbktarget=workbooks.open("E:\HARGA.xlsm")
if wbktarget is nothing then
msgbox "Tidak ada workbooknya.",vbexclamation,"simpan"
application.screenupdating=true
exit sub
elseif wbktarget.readonly then
msgbox "Maaf, file STOCK.xlsm sedang dibuka, silahkan tutup file
terlebih dahulu..",vbexclamation,"simpan"
application.screenupdating=true
exit sub
endif
'simpan range target
with wbktarget.sheets("DATA PENJUALAN")
set rngTarget= .cells(.rows.count,1).end(xlup).offset(1)
end with
'mulai proses
wbkapp.activate
with wbkapp.sheets("CETAK NOTA")
.autofiltermode=false
set rngData=.range("a5:o123456")
set rngCopy=.range("b5:o123456")
lAwal=.range("L1").value
lAkhir=.range("L2").value
'tampilkan semua kolom
rngdata.entirecolumn.hidden=false
'hide kolom yang tidak akan diambil yaitu F,G,J,K,L,M
.range("F:G,J:M").hidden=true
'filter kolom A (Kelompok) dari lAwal sampai lAkhir
rngdata.autofilter 1,">=" & lawal , xlAnd , "<=" & lAkhir
'copy yang tampak
rngcopy.offset(1).specialcells(xlCellTypeVisible).copy
'paste values dan format tanpa yang blank ke rngtarget
rngtarget.pastespecial xlPasteValuesAndNumberFormats ,skipblanks:=true
'lepas auto filter
.autofiltermode=false
'unhide semua kolom
rngdata.entirecolumn.hidden=false
'hide kolom-kolom tambahan, yaitu A,B,D,N,O,P
.range("A:B,D:D,N:P").hidden=true
end with
'tutup workbook target dengan save
application.displayalerts=false
wbktarget.close true
application.displayalerts=true
application.screenupdating=true
msgbox "Saved.",vbinformation,"simpan"
--------
Wassalam,
Kid
On Sat, Aug 22, 2015 at 12:31 AM, Ivan Sebastian [email protected]
[belajar-excel] <[email protected]> wrote:
>
>
> BeExceller,
> ada satu lg rumus makro yg memakan waktu untuk pemindahan data ke database
> harga..saya lampirkan contoh file notanya, bila nota penjualan mencapai
> maksimal dalam hal ini saya batasi 25 nota.. untuk kedepannya akan saya
> buat 70 nota atau lebih.. untuk pemindahan datanya berasa lama banget..
> kurang lebih 3-5 menit..
> makronya seperti ini...kira2 apa masih bisa diperingkas lagi rumusnya
> untuk mempercepat pemindahan datanya ke database harga..(database harganya
> sama seperti file yg saya lampirkan sebelumnya (ukuran file harga kebesaran
> jadi sama mimin didelete molo)
>
> Sub HARGA()
> A = Range("I1").Value
> B = Range("I2").Value
> Application.ScreenUpdating = False
> For x = A To B
> SaveTo_DataPenjualan (x)
> Next x
> Application.ScreenUpdating = True
> End Sub
> Private Sub SaveTo_DataPenjualan(lembar_ke As Long)
> Dim rng As Range, cell As Range, targetCell As Range, CODE As String, i
> As Long
>
> With Sheets("CETAK NOTA")
> If lembar_ke = 1 Then
> Set rng = .Range("A6:A21")
> CODE = .Range("E1").Value
> TANGGAL = .Range("G1").Value
> NAMA = .Range("B1").Value
> ElseIf lembar_ke = 2 Then
> Set rng = .Range("A31:A46")
> CODE = .Range("E26").Value
> TANGGAL = .Range("G26").Value
> NAMA = .Range("B26").Value
> ElseIf lembar_ke = 3 Then
> Set rng = .Range("A56:A71")
> CODE = .Range("E51").Value
> TANGGAL = .Range("G51").Value
> NAMA = .Range("B51").Value
> ElseIf lembar_ke = 4 Then
> Set rng = .Range("A81:A96")
> CODE = .Range("E76").Value
> TANGGAL = .Range("G76").Value
> NAMA = .Range("B76").Value
> ElseIf lembar_ke = 5 Then
> Set rng = .Range("A106:A121")
> CODE = .Range("E101").Value
> TANGGAL = .Range("G101").Value
> NAMA = .Range("B101").Value
> ElseIf lembar_ke = 6 Then
> Set rng = .Range("A131:A146")
> CODE = .Range("E126").Value
> TANGGAL = .Range("G126").Value
> NAMA = .Range("B126").Value
> ElseIf lembar_ke = 7 Then
> Set rng = .Range("A156:A171")
> CODE = .Range("E151").Value
> TANGGAL = .Range("G151").Value
> NAMA = .Range("B151").Value
> ElseIf lembar_ke = 8 Then
> Set rng = .Range("A181:A196")
> CODE = .Range("E176").Value
> TANGGAL = .Range("G176").Value
> NAMA = .Range("B176").Value
> ElseIf lembar_ke = 9 Then
> Set rng = .Range("A206:A221")
> CODE = .Range("E201").Value
> TANGGAL = .Range("G201").Value
> NAMA = .Range("B201").Value
> ElseIf lembar_ke = 10 Then
> Set rng = .Range("A231:A246")
> CODE = .Range("E226").Value
> TANGGAL = .Range("G226").Value
> NAMA = .Range("B226").Value
> ElseIf lembar_ke = 11 Then
> Set rng = .Range("A256:A271")
> CODE = .Range("E251").Value
> TANGGAL = .Range("G251").Value
> NAMA = .Range("B251").Value
> ElseIf lembar_ke = 12 Then
> Set rng = .Range("A281:A296")
> CODE = .Range("E276").Value
> TANGGAL = .Range("G276").Value
> NAMA = .Range("B276").Value
> ElseIf lembar_ke = 13 Then
> Set rng = .Range("A306:A321")
> CODE = .Range("E301").Value
> TANGGAL = .Range("G301").Value
> NAMA = .Range("B301").Value
> ElseIf lembar_ke = 14 Then
> Set rng = .Range("A331:A346")
> CODE = .Range("E326").Value
> TANGGAL = .Range("G326").Value
> NAMA = .Range("B326").Value
> ElseIf lembar_ke = 15 Then
> Set rng = .Range("A356:A371")
> CODE = .Range("E351").Value
> TANGGAL = .Range("G351").Value
> NAMA = .Range("B351").Value
> ElseIf lembar_ke = 16 Then
> Set rng = .Range("A381:A396")
> CODE = .Range("E376").Value
> TANGGAL = .Range("G376").Value
> NAMA = .Range("B376").Value
> ElseIf lembar_ke = 17 Then
> Set rng = .Range("A406:A421")
> CODE = .Range("E401").Value
> TANGGAL = .Range("G401").Value
> NAMA = .Range("B401").Value
> ElseIf lembar_ke = 18 Then
> Set rng = .Range("A431:A446")
> CODE = .Range("E426").Value
> TANGGAL = .Range("G426").Value
> NAMA = .Range("B426").Value
> ElseIf lembar_ke = 19 Then
> Set rng = .Range("A456:A471")
> CODE = .Range("E451").Value
> TANGGAL = .Range("G451").Value
> NAMA = .Range("B451").Value
> ElseIf lembar_ke = 20 Then
> Set rng = .Range("A481:A496")
> CODE = .Range("E476").Value
> TANGGAL = .Range("G476").Value
> NAMA = .Range("B476").Value
> ElseIf lembar_ke = 21 Then
> Set rng = .Range("A506:A521")
> CODE = .Range("E501").Value
> TANGGAL = .Range("G501").Value
> NAMA = .Range("B501").Value
> ElseIf lembar_ke = 22 Then
> Set rng = .Range("A531:A546")
> CODE = .Range("E526").Value
> TANGGAL = .Range("G526").Value
> NAMA = .Range("B526").Value
> ElseIf lembar_ke = 23 Then
> Set rng = .Range("A556:A571")
> CODE = .Range("E551").Value
> TANGGAL = .Range("G551").Value
> NAMA = .Range("B551").Value
> ElseIf lembar_ke = 24 Then
> Set rng = .Range("A581:A596")
> CODE = .Range("E576").Value
> TANGGAL = .Range("G576").Value
> NAMA = .Range("B576").Value
> Else
> Set rng = .Range("A606:A621")
> CODE = .Range("E601").Value
> TANGGAL = .Range("G601").Value
> NAMA = .Range("B601").Value
> End If
> End With
>
> Application.ScreenUpdating = False
>
> If IsFileOpen("E:\HARGA.xlsm") Then
>
> MsgBox "Maaf, file STOCK.xlsm sedang dibuka, silahkan tutup file terlebih
> dahulu.."
> Exit Sub
> End If
>
> Workbooks.Open FileName:="E:\HARGA.xlsm"
>
> With Sheets("DATA PENJUALAN")
> Set targetCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
>
> End With
> For i = 1 To rng.Rows.Count
> Set cell = rng.Cells(i, 1)
> If cell.Value <> "" Then
> targetCell.Value = CODE
> targetCell.Offset(0, 1).Value = cell.Value
> targetCell.Offset(0, 2).Value = NAMA
> targetCell.Offset(0, 3).Value = cell.Offset(0, 1).Value
> targetCell.Offset(0, 4).Value = cell.Offset(0, 4).Value
> targetCell.Offset(0, 5).Value = cell.Offset(0, 5).Value
> targetCell.Offset(0, 7).Value = TANGGAL
> Set targetCell = targetCell.Offset(1, 0)
> End If
> Next i
>
> Workbooks("HARGA.xlsm").SAVE
> Workbooks("HARGA.xlsm").Close
> Application.ScreenUpdating = True
> End Sub
> Function IsFileOpen(FileName As String)
> Dim iFilenum As Long
> Dim iErr As Long
>
> On Error Resume Next
> iFilenum = FreeFile()
> Open FileName For Input Lock Read As #iFilenum
> Close iFilenum
> iErr = Err
> On Error GoTo 0
>
> Select Case iErr
> Case 0: IsFileOpen = False
> Case 70: IsFileOpen = True
> Case Else: Error iErr
> End Select
>
> End Function
>
>
>
>
>
>
>
>
>
