Makasih banyak mr kid... Cuman sayangnya saya kurang paham maksudnya.. Hihihi.. Kalo boleh minta rumus yg jadiannya mr kid..
Sent from my iPad mini > On 30 Agt 2015, at 14.29, 'Mr. Kid' [email protected] [belajar-excel] > <[email protected]> wrote: > > 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).Valu > 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 >> >> >> >> >> >> >> > >
