Minggu, 23 Agustus 2015

[belajar-excel] Digest Number 3546

2 Messages

Digest #3546

Messages

Sat Aug 22, 2015 4:39 am (PDT) . Posted by:

"Ivan Sebastian" layonardo

terima kasih banyak mr kid... semakin sempurna rumus makronya...


Pada Jumat, 21 Agustus 2015 21:52, "'Mr. Kid' mr.nmkid@gmail.com [belajar-excel]" <belajar-excel@yahoogroups.com> menulis:


 
Bagian penulis nomor urut record ini :
r = Sheets("DATA PENJUALAN").Range("I1").CurrentRegion.Rows.Count - 1
    Sheets("DATA PENJUALAN").Range("I1").Select
    For i = Cells(9, 9) To r
        ActiveCell = i
        ActiveCell.Offset(1, 0).Select
    Next i
Range("I1").FormulaR1C1 = "No"

Bisa diganti menjadi :
dim i as long
with Sheets("DATA PENJUALAN")   i=.Range("I1").CurrentRegion.Rows.Count - 1   .range("i2").resize(i).value=evaluate("=row(1:" & i & ")")
   .range("i1").value="No"
end with

Bagian sort descending ini :
Columns("A:I").Select
    ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort.SortFields.CLEAR
    ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort.SortFields.Add Key:=Range( _
        "I:I"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort
        .SetRange Range("A:I")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Bisa diubah menjadi :
with Sheets("DATA PENJUALAN").range("a1:i1").currentregion
      .sort .cells(1,9) , xldescending , header:=xlyes , orientation:=xlsortcolumns
end with

*** ganti xldescending menjadi xlascending untuk part sort ascending setelah removeduplicate

Bagian remove duplicate ini :
ActiveSheet.Range("A:I").RemoveDuplicates Columns:=Array(3, 4), _
        Header:=xlYes

Bisa diubah menjadi :
Sheets("DATA PENJUALAN").range("a1:i1").currentregion.removeduplicates array(3,4) , xlyes

Bila perlu, tambahkan tepat setelah baris dim sebelum proses tulis nomor urut bunyi berikut :
      application.screenupdating=false
dan tepat sebelum end sub bunyi berikut :
      application.screenupdating=true

Wassalam,
Kid

2015-08-21 18:17 GMT+07:00 Ivan Sebastian layonardo@yahoo.co.id [belajar-excel] <belajar-excel@yahoogroups.com>:

  --- Mods ---
File lampiran lebih dari 250KB dilepas dari email. Silakan pemosting melakukan posting file lampiran yang diusahakan maksimal 250KB dengan cara me-reply email ini.
---------------

terima kasih mr kid...saya sudah berhasil memodif formula yg menurut saya ini yg paling sesuai makronya... waktu yg dibutuhkan untuk meremove data kembar dan menyisakan data paling baru dalam ribuan data cuman 3dtk kurang lebihnya...
makro saya seperti ini.. bilamana ada yg janggal menurut mr kid.. mohon bantuan dan bimbingannya untuk perbaikan dari rumus ini.. karena saya cuman bermodal coba2 modif sendiri...

Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Columns("I:I").EntireColumn.Hidden = False

r = Sheets("DATA PENJUALAN").Range("I1").CurrentRegion.Rows.Count - 1
    Sheets("DATA PENJUALAN").Range("I1").Select
    For i = Cells(9, 9) To r
        ActiveCell = i
        ActiveCell.Offset(1, 0).Select
    Next i
Range("I1").FormulaR1C1 = "No"

Columns("A:I").Select
    ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort.SortFields.CLEAR
    ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort.SortFields.Add Key:=Range( _
        "I:I"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort
        .SetRange Range("A:I")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("A:I").RemoveDuplicates Columns:=Array(3, 4), _
        Header:=xlYes
    ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort.SortFields.CLEAR
    ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort.SortFields.Add Key:=Range( _
        "I:I"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("DATA PENJUALAN").Sort
        .SetRange Range("A:I")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range("I:I").ClearContents
Range("I1").FormulaR1C1 = "No"
Columns("A:H").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Columns("I:I").EntireColumn.Hidden = True
End Sub

Pada Jumat, 21 Agustus 2015 1:50, "'Mr. Kid' mr.nmkid@gmail.com [belajar-excel]" menulis:


  Untuk menulis nomor baris dengan baris kode :
'misal pada nomor baris diletakkan di K11:K19 (ada 9) baris, nomor mulai dari 1
sheets("nama sheet target").range("k11:k19").value=evaluate("=Row(1:9)")

Andai menggunakan fitur Excel Table, maka penulisan nomor baris tidak diperlukan.
Contoh ada tabel data dengan kolom dari A sampai D, header di baris 1 (range A1:D1), data mulai A2.
Di kolom E diberi header (range E1) NomorBaris. Dengan cell E2 berisi formula =Row()-1
Langkah pertama (cukup dijalankan sekali saja) adalah membuat object Excel table. Caranya blok A1 sampai kolom E baris terakhir data (kolom berformula nomor baris ikut terblok). Kemudian ribbon Home -> group Styles -> format as table -> pilih salah satu styles yang ada.

Setiap kali ada data baru, paste-kan dibaris kosong pertama (tidak boleh ada baris kosong antar data). Pastikan data yang dipaste hanya berisi 4 kolom karena header kolom pokok ada di A sampai D dan kolom E adalah tambahan.
Kemudian langkah remove duplicate nya adalah :
1. sort kolom E secara descending (largest to smallest)
2. lakukan remove duplicate (centang kolom yang menjadi kunci unique records, dan pastikan kolom E tidak dicentang)
3. jika muncul kotak pesan bahwa tidak ada data yang di-remove atau tidak ada yang duplicate, maka lakukan sort lagi secara descending. Tapi jika kotak pesan yang muncul menunjukkan ada sekian record yang di remove, maka tidak perlu sort lagi.

Jika ternyata kolom data yang dipaste bisa berubah-ubah jumlahnya, maka dibalik posisinya.
Kolom A berisi formula =Row()-1, dan data pokok dipaste mulai kolom B.

Wassalam,
Kid

2015-08-18 10:14 GMT+07:00 Ivansl layonardo@yahoo.co.id [belajar-excel] <belajar-excel@yahoogroups.com>:

  Terima kasih atas sarannya mr kid... Sudah saya ikutin langkah2nya.. Dan sudah saya record ke dalam bentuk makro.. Cuman muncul satu permasalahan lg.. Bagaimana supaya no urut baris tiap kali ada data record terbaru otomatis no urut terisi dengan sendirinya?  Apa harus manual terus untuk pengisian nomer urut baris??

On 18 Agt 2015, at 05.10, 'Mr. Kid' mr.nmkid@gmail.com [belajar-excel] <belajar-excel@yahoogroups.com> wrote:

  Hai Layonardo,

Fitur remove duplicate selalu membuang record yang lebih bawah. Jadi, ketika bisa membuat urutan record menjadi terbalik sesaat saja, maka fitur ini bisa digunakan.

Biasanya data histori memiliki kolom last update berisi tanggal dan waktu si record ditulis ke dalam tabel. Fitur remove duplicate bisa digunakan dengan didahului proses pengurutan data secara menurun (descending) berdasar kolom last update ini. Kemudian mengembalikan lagi urutannya menjadi menaik (ascending) berdasar kolom last update, jika dituntut bahwa unique records yang masuk ke dalam tabel yang terbaru tetap di baris yang bawah.

Andaikan tabel tidak memiliki kolom berisi tanggal dan waktu last update, maka diperlukan pembuatan kolom baru di kanan tabel data (rapat dengan kolom terakhir data) yang diisi dengan nomor baris record (bisa mulai dari 1 ataupun dari angka berapa saja asal berurut). Langkahnya begini :
1. Misal diberi header bernama Baris.
2. Lalu di record ke-1 diisi angka 1, dan record ke-2 diisi angka 2.
3. blok angka 1 dan 2 yang di-input di no 2 -> gerakkan mouse ke pojok kanan bawah sampai icon berubah menjadi + hitam padat -> double click mouse -> periksa bahwa seluruh record sudah memiliki nomor urut.
4. Blok seluruh tabel (header, semua kolom termasuk kolom baru ini, seluruh baris)
5. sort berdasar kolom baru bernama Baris secara Descending
6. lakukan remove duplicate berdasar kolom-kolom kunci (pastikan kolom Baris bukan menjadi kunci dalam remove duplicate)
7. sort lagi berdasar kolom baru bernama Baris secara Ascending.

Proses diatas bisa

Wassalam,
Kid

2015-08-17 23:40 GMT+07:00 layonardo@yahoo.co.id [belajar-excel] <belajar-excel@yahoogroups.com>:

  dear all master... mohon bantuan untuk rumus makronya...
langsung ke topiknya.. saya pingin menghapus data kembar.dan menyisakan data yg paling baru...
sebenarnya cara paling cepat adalah pakai remove duplikat dari bawaan excel sendiri cuman sayangnya... data yg dihapus malah yg terbaru... dan menyisakan data yg lama saja... nah yg saya inginkan justru sebaliknya...

data saya lampirkan.. bisa langsung di cek ke bagian sheet "data penjualan".. disana saya siapkan 1 tombol hapus dan saya ingin hasilnya seperti di sheet "contoh hasil tombol hapus" mohon bantuannya... semoga paham maksud saya...

saya ada nemu rumus makro ini cuman bilamana datanya mencapai 5000an or lebih dari itu.. prosesnya memakan waktu yg cukup lama sekitar 2-3 menit.. yg mana menurut saya cukup lama... sebaliknya rumus bawaan excelnya(remove duplikat) malah lebih cepat... bahkan ga sampe 30 dtk...

Sub hapus()

Dim brs As Long

Dim i As Long

Dim j As Long

Dim ROW_DELETED As Boolean

brs = WorksheetFunction.CountA(ActiveSheet.Range("A:A")) - 1

Application.ScreenUpdating = False

For x = 1 To brs

ActiveSheet.Range("Q" x + 1).Value = ActiveSheet.Range("C" x + 1).Value ActiveSheet.Range("D" x + 1).Value

Next x

i = 2

Do While i <= ActiveSheet.UsedRange.Rows.Count

    ROW_DELETED = False

    For j = i + 1 To ActiveSheet.UsedRange.Rows.Count

        If Cells(i, 17) = Cells(j, 17) Then

            Rows(i).Delete

            ROW_DELETED = True

            Exit For

        End If

    Next j

    If Not ROW_DELETED Then i = i + 1

Loop

For x = 1 To brs

ActiveSheet.Range("Q" x + 1).ClearContents

Next x

Application.ScreenUpdating = True

End Sub

--- Mods ---
File lampiran yang lebih dari 250KB dilepas dari postingan. Silakan penanya melampirkan ulang file yang diusahakan maksimal 250KB dengan cara me-reply email ini.
----------------

#yiv2032098483 #yiv2032098483 -- #yiv2032098483ygrp-mkp {border:1px solid #d8d8d8;font-family:Arial;margin:10px 0;padding:0 10px;}#yiv2032098483 #yiv2032098483ygrp-mkp hr {border:1px solid #d8d8d8;}#yiv2032098483 #yiv2032098483ygrp-mkp #yiv2032098483hd {color:#628c2a;font-size:85%;font-weight:700;line-height:122%;margin:10px 0;}#yiv2032098483 #yiv2032098483ygrp-mkp #yiv2032098483ads {margin-bottom:10px;}#yiv2032098483 #yiv2032098483ygrp-mkp .yiv2032098483ad {padding:0 0;}#yiv2032098483 #yiv2032098483ygrp-mkp .yiv2032098483ad p {margin:0;}#yiv2032098483 #yiv2032098483ygrp-mkp .yiv2032098483ad a {color:#0000ff;text-decoration:none;}#yiv2032098483 #yiv2032098483ygrp-sponsor #yiv2032098483ygrp-lc {font-family:Arial;}#yiv2032098483 #yiv2032098483ygrp-sponsor #yiv2032098483ygrp-lc #yiv2032098483hd {margin:10px 0px;font-weight:700;font-size:78%;line-height:122%;}#yiv2032098483 #yiv2032098483ygrp-sponsor #yiv2032098483ygrp-lc .yiv2032098483ad {margin-bottom:10px;padding:0 0;}#yiv2032098483 #yiv2032098483actions {font-family:Verdana;font-size:11px;padding:10px 0;}#yiv2032098483 #yiv2032098483activity {background-color:#e0ecee;float:left;font-family:Verdana;font-size:10px;padding:10px;}#yiv2032098483 #yiv2032098483activity span {font-weight:700;}#yiv2032098483 #yiv2032098483activity span:first-child {text-transform:uppercase;}#yiv2032098483 #yiv2032098483activity span a {color:#5085b6;text-decoration:none;}#yiv2032098483 #yiv2032098483activity span span {color:#ff7900;}#yiv2032098483 #yiv2032098483activity span .yiv2032098483underline {text-decoration:underline;}#yiv2032098483 .yiv2032098483attach {clear:both;display:table;font-family:Arial;font-size:12px;padding:10px 0;width:400px;}#yiv2032098483 .yiv2032098483attach div a {text-decoration:none;}#yiv2032098483 .yiv2032098483attach img {border:none;padding-right:5px;}#yiv2032098483 .yiv2032098483attach label {display:block;margin-bottom:5px;}#yiv2032098483 .yiv2032098483attach label a {text-decoration:none;}#yiv2032098483 blockquote {margin:0 0 0 4px;}#yiv2032098483 .yiv2032098483bold {font-family:Arial;font-size:13px;font-weight:700;}#yiv2032098483 .yiv2032098483bold a {text-decoration:none;}#yiv2032098483 dd.yiv2032098483last p a {font-family:Verdana;font-weight:700;}#yiv2032098483 dd.yiv2032098483last p span {margin-right:10px;font-family:Verdana;font-weight:700;}#yiv2032098483 dd.yiv2032098483last p span.yiv2032098483yshortcuts {margin-right:0;}#yiv2032098483 div.yiv2032098483attach-table div div a {text-decoration:none;}#yiv2032098483 div.yiv2032098483attach-table {width:400px;}#yiv2032098483 div.yiv2032098483file-title a, #yiv2032098483 div.yiv2032098483file-title a:active, #yiv2032098483 div.yiv2032098483file-title a:hover, #yiv2032098483 div.yiv2032098483file-title a:visited {text-decoration:none;}#yiv2032098483 div.yiv2032098483photo-title a, #yiv2032098483 div.yiv2032098483photo-title a:active, #yiv2032098483 div.yiv2032098483photo-title a:hover, #yiv2032098483 div.yiv2032098483photo-title a:visited {text-decoration:none;}#yiv2032098483 div#yiv2032098483ygrp-mlmsg #yiv2032098483ygrp-msg p a span.yiv2032098483yshortcuts {font-family:Verdana;font-size:10px;font-weight:normal;}#yiv2032098483 .yiv2032098483green {color:#628c2a;}#yiv2032098483 .yiv2032098483MsoNormal {margin:0 0 0 0;}#yiv2032098483 o {font-size:0;}#yiv2032098483 #yiv2032098483photos div {float:left;width:72px;}#yiv2032098483 #yiv2032098483photos div div {border:1px solid #666666;height:62px;overflow:hidden;width:62px;}#yiv2032098483 #yiv2032098483photos div label {color:#666666;font-size:10px;overflow:hidden;text-align:center;white-space:nowrap;width:64px;}#yiv2032098483 #yiv2032098483reco-category {font-size:77%;}#yiv2032098483 #yiv2032098483reco-desc {font-size:77%;}#yiv2032098483 .yiv2032098483replbq {margin:4px;}#yiv2032098483 #yiv2032098483ygrp-actbar div a:first-child {margin-right:2px;padding-right:5px;}#yiv2032098483 #yiv2032098483ygrp-mlmsg {font-size:13px;font-family:Arial, helvetica, clean, sans-serif;}#yiv2032098483 #yiv2032098483ygrp-mlmsg table {font-size:inherit;font:100%;}#yiv2032098483 #yiv2032098483ygrp-mlmsg select, #yiv2032098483 input, #yiv2032098483 textarea {font:99% Arial, Helvetica, clean, sans-serif;}#yiv2032098483 #yiv2032098483ygrp-mlmsg pre, #yiv2032098483 code {font:115% monospace;}#yiv2032098483 #yiv2032098483ygrp-mlmsg * {line-height:1.22em;}#yiv2032098483 #yiv2032098483ygrp-mlmsg #yiv2032098483logo {padding-bottom:10px;}#yiv2032098483 #yiv2032098483ygrp-msg p a {font-family:Verdana;}#yiv2032098483 #yiv2032098483ygrp-msg p#yiv2032098483attach-count span {color:#1E66AE;font-weight:700;}#yiv2032098483 #yiv2032098483ygrp-reco #yiv2032098483reco-head {color:#ff7900;font-weight:700;}#yiv2032098483 #yiv2032098483ygrp-reco {margin-bottom:20px;padding:0px;}#yiv2032098483 #yiv2032098483ygrp-sponsor #yiv2032098483ov li a {font-size:130%;text-decoration:none;}#yiv2032098483 #yiv2032098483ygrp-sponsor #yiv2032098483ov li {font-size:77%;list-style-type:square;padding:6px 0;}#yiv2032098483 #yiv2032098483ygrp-sponsor #yiv2032098483ov ul {margin:0;padding:0 0 0 8px;}#yiv2032098483 #yiv2032098483ygrp-text {font-family:Georgia;}#yiv2032098483 #yiv2032098483ygrp-text p {margin:0 0 1em 0;}#yiv2032098483 #yiv2032098483ygrp-text tt {font-size:120%;}#yiv2032098483 #yiv2032098483ygrp-vital ul li:last-child {border-right:none !important;}#yiv2032098483

Sat Aug 22, 2015 4:41 am (PDT) . Posted by:

"Ivan Sebastian" layonardo


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










Pada Sabtu, 22 Agustus 2015 0:29, Ivan Sebastian menulis:



mr kid, 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

















============================================================
Pojok Lowongan Kerja yang disediakan milis :
http://milis-belajar-excel.1048464.n5.nabble.com/Pojok-Lowongan-Kerja-f5725753.html
*** Posting lowongan kerja : ke link tersebut dan klik New Topic
============================================================
bergabung ke milis (subscribe), kirim mail kosong ke: belajar-excel-subscribe@yahoogroups.com
posting ke milis, kirimkan ke: belajar-excel@yahoogroups.com
berkunjung ke web milis : http://tech.groups.yahoo.com/group/belajar-excel/messages
melihat file archive / mendownload lampiran : http://www.mail-archive.com/belajar-excel@yahoogroups.com/
atau (sejak 25-Apr-2011) bisa juga di : http://milis-belajar-excel.1048464.n5.nabble.com/
menghubungi moderators & owners: belajar-excel-owner@yahoogroups.com
keluar dari membership milis (UnSubscribe), kirim mail kosong ke : belajar-excel-unsubscribe@yahoogroups.com
---------------------------------------------------------------------

Tidak ada komentar:

Poskan Komentar