Sabtu, 05 Oktober 2013

[belajar-excel] Digest Number 2580

15 New Messages

Digest #2580
4a
VBA copy paste???? by "Shenly" shenly_excelmania
4b
Re: VBA copy paste???? [1 Attachment] by "Mr. Kid" nmkid.family@ymail.com
5a
Re: Encryption by "prazt math" praztmath
5b
Bls: Re: [belajar-excel] Encryption by "De Premor" de.premor

Messages

Fri Oct 4, 2013 7:59 am (PDT) . Posted by:

"Mr. Kid" nmkid.family@ymail.com

Supaya ndak perlu mengaktifkan sheet rekap detail, coba baris kode :
Sheets("rekap detail").Activate
Set SrcData = Sheets("rekap detail").Range("E2",
Range("E2").End(xlDown))
diubah menjadi :
Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap detail").
Range("E2").End(xlDown))

Wassalam,
Kid.

2013/10/4 hendrik karnadi <hendrikkarnadi@yahoo.com>

> **
>
>
> Jangan putus asa dulu.
> Coba copas lagi macro ini pada VBE Sheet (Module1).
>
> Sub Masukin()
> Dim SrcData As Range, Rng As Range
> Dim cKode As New Collection
> Dim LRow As Long
>
> Application.ScreenUpdating = False
> Sheets("rekap detail").Activate
> Set SrcData = Sheets("rekap detail").Range("E2",
> Range("E2").End(xlDown))
>
> On Error Resume Next
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng)
> Next
>
> For LRow = 1 To cKode.Count
> Set Rng = SrcData.CurrentRegion.Offset(1,
> 0).Resize(SrcData.Rows.Count, 6)
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sheets(cKode.Item(LRow)).Range("A2")
> SrcData.CurrentRegion.AutoFilter
> Next
> Application.ScreenUpdating = True
> End Sub
>
> Mengapa timbul run time error ?
> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>
> Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah macronya
> dicopas di VBE Sheet) maka perlu ditambahkan instruksi warna merah, artinya
> Sheet "rekap detail" harus diaktifkan dulu.
>
> Salam,
> HK
>
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 14:54
> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet [1 Attachment]
>
>
> Dear bro Hendrik,
>
> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro... namanya
> newbe and juga pengen tau bisa gimana caranya.
>
> kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan bisa buat
> ngerjain yang lain.. hehehe
>
> terlampir format data yang biasa digunakan.
>
>
>
> many thanks
> Ahmad H
>
>
>
> ------------------------------
> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
> *Dikirim:* Jumat, 4 Oktober 2013 14:33
> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> Saya sdh tes dan filenya masih disimpan.
>
> Coba kirim file yang ada "run time errornya" karena dengan
> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin memahami dan
> menikmati macro.
>
> JIka anda mau email satu persatu (balasan email anda kepada Miss Jan)
> kenapa ga langung disave sebagai workbook (pada Dir yang sama) per nama PT ?
>
> Salam,
> HK
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 14:02
> *Subject:* Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> Dear Bro Hendrik,
>
> kok nggak bisa ya.. "run time error"
>
> maaf newbe nih... hihihihiihi
>
> mohon bantuannya lagi ya bro...
>
>
> many thanks,
> cheers
> Ahmad H
>
>
>
> ------------------------------
> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
> *Dikirim:* Jumat, 4 Oktober 2013 12:36
> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste (breakdown)
> sheet to sheet
>
>
> Pak De, boleh pinjam codenya ya ?
> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA Module1
> (diambil dari kasus filtering sebelumnya),
>
> Sub Masukin()
> Dim SrcData As Range, Rng As Range
> Dim cKode As New Collection
> Dim LRow As Long
>
> Application.ScreenUpdating = False
> Set SrcData = Sheets("rekap detail").Range("E2", Range("E2
> ").End(xlDown))
>
> On Error Resume Next
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng)
> Next
>
> For LRow = 1 To cKode.Count
> Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count,
> 6)
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sheets(cKode.Item(LRow)).Range("A2")
> SrcData.CurrentRegion.AutoFilter
> Next
> Application.ScreenUpdating = True
> End Sub
>
> Warna merah adalah bagian yang disesuaikan.
>
> Salam,
> HK
>
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 10:57
> *Subject:* [belajar-excel] Need Help melakukan copy paste (breakdown)
> sheet to sheet [1 Attachment]
>
>
> Selamat Pagi,
>
> mudah-mudah an semua anggota di belajar-excel ini selalu mendapatkan
> keberkahan dalam hidup. amin
>
> dalam hal ini saya mau minta mohon bantuannya untuk permasalahan yang saya
> alami,
>
> dikarenakan olah data ini dilakukan 2 hari sekali maka akan sangat
> membantu jika dapat di lakukan otomasi by vb or macro.
>
> dalam 1 file excel terdapat sheet file detail dan beberapa sheet breakdown
> nya.
>
> berikut saya lampirkan file yang dimaksud.
>
> atas perhatian dan bantuannya terima kasih
>
> cheers,
> Ahmad H
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

Fri Oct 4, 2013 8:08 am (PDT) . Posted by:

"hendrik karnadi" hendrikkarnadi

Kalau masih penasaran mau pencet-pencet tombol dan copy datanya pada sheets yang disediakan,
silakan mainkan file pada lampiran email ini.
- Tombol Copy to Sheet untuk mengcopy rekap detail ke Vendor Sheets
- Tombol CLEAR DATA untuk menghapus data pada Vendor Sheets (hanya tinggal judul saja)

Salam,
HK

________________________________
From: Ahmad Habibillah <abiel_1108@yahoo.com>
To: belajar-excel@yahoogroups.com
Sent: Friday, 4 October 2013, 14:59
Subject: Bls: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet


 
dear Miss Jan,

thanks atas bantuannya Miss, 

yes miss dengan cara itu ok sip, its work..

tapi kalau aja.. hehehhehe bisa by command button.. 
hasil nya pastinya akan lebih sempurna dengan format atau bentuk data yang sesuai dengan yang diinginkan.

bai de wei... eni wei... bas wei...  tengkyuuu pisan...

thanks
Ahmad H

________________________________
Dari: Jan Raisin <miss.jan.raisin@gmail.com>
Kepada: belajar-excel@yahoogroups.com
Dikirim: Jumat, 4 Oktober 2013 14:22
Judul: Re: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet


 
owh.. jadi nanti hasilnya mau dicopas ke workbook lain
lalu workbook tersebut akan dikirim ke masing-masing perusahaan ya..

maaf deh.. Jan kan gak tau.. xixixixi ^_^

bai de wei... eni wei... bas wei..
pernah dengar istilah paste special? ^_^

caranya waktu mau paste ke sheet yang diinginkan, jangan tekan tombol CTRL + V atau klik Paste
tetapi.... klik kanan tombol kanan mouse, pilih Paste Special..
lalu pilih jenis pastenya seperti apa.. 

kalo dalam kasus ini berarti seperti gambar di bawah ini:

karena yang diinginkan hanya nilai dan format angkanya saja, maka pilih Values and number formats
setelah itu klik OK

kalo yang diinginkan beda.. tinggal dipilih saja yang sesuai.. karena di situ banyak pilihannya kok..

tetap semangat.. ^_^

-Miss Jan Raisin-

Pada 4 Oktober 2013 14.00, Ahmad Habibillah <abiel_1108@yahoo.com> menulis:

> 
>hai juga Miss Jan,
>
>
>waduh... many thanks untuk solusinya, mantaaapppp.
>
>
>tapi masih ada tapi nya nih... :(
>
>
>kalau yang seperti itu saya gunakan untuk diinternal, 
>
>
>sebenarnya nantinya jika sudah bisa di copy paste sheet to sheet, masing sheet PT A, PT B dst bakalan saya move or copy satu satu, dan akan saya kirimkan by mail ke masing-masing PT, 
>
>
>kalau masih dengan format pivot kan bisa di filter nya select all terbuka deh semua PT nya.
>
>
>mohon bantuannya ya Miss.
>
>
>many thanks
>cheers,
>Ahmad H
>
>

Fri Oct 4, 2013 8:10 am (PDT) . Posted by:

"Mr. Kid" nmkid.family@ymail.com

PakD,

script dengan loop add collection dibuat terpisah dengan proses susun
output file itu dibandingkan dengan kalau loop add collection diisi
sekalian dengan proses susun output file, akan cepat mana ya ? (sorry ndak
sempet nyoba).
mungkin bisa lebih cepat kalau dalam add collection ada proses susun output
file deh.

Wassalam,
Kid.

2013/10/4 De Premor <de@premor.net>

> **
>
>
> ikutan nimbrung ya mas HK
> Buat error yang sebelumnya bisa tanpa berpindah sheet dulu dengan cara
> begini
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap detail").
> Range("E2").End(xlDown))
>
> berikut kode buat ngefilter per pt, kemudian mengkopy ke sheet baru, lalu
> dipindah ke workbook baru, selanjutnya disimpen, setelah itu di close
> workbook barunya.
> *kalau perlu ditambahi kode buat ngirim email ke masing2 tujuan sekalian,
> jadi tinggal pencet tombol trus duduk manis atau "**ngerjain **yang lain**"
> hehehe*
>
> Sub ExportPerPT()
> Dim SrcData As Range, Rng As Range, cKode As New Collection
> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile as String
>
> Application.ScreenUpdating = False
> Application.DisplayAlerts = False
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> On Error Resume Next 'Proses setelah ini akan menghasilkan error jika
> ada data duplikat, maka buat error handlernya
>
> For Each Rng In SrcData
> cKode.Add Trim(Rng),
> CStr(Rng) 'Buat List Unique
> Nama2 PT
> Next
>
> Fld = ThisWorkbook.Path & "\Buat
> Dikirim\" 'Lokasi Pulder buat nyimpen
> data export'an
> If Dir(Fld, vbDirectory) = "" Then MkDir
> Fld 'Jika belum ada foldernya, dibuat ajah
>
> Set Rng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count,
> 6) 'Inget2 lokasi Data yang mau dicopy
>
>
> For LRow = 1 To cKode.Count
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow) 'AutoFilter
>
> Worksheets.Add 'Buat
> Sheet Baru
> Set Sh =
> ActiveSheet 'Ingat2
> Sheet barunya
> Sh.Name = Left(cKode.Item(LRow),
> 31) 'Ganti Nama Sheet baru menjadi
> nama PT (Max 31 Karakter)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sh.Range("A1") 'Copy Data Dari Rekap Detail ke Sheet Baru
>
> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas
> kan lebar kolom
>
> Sh.Move 'Pindahkan
> Sheetbaru ke workbook baru
> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> 'Simpen workbook barunya sesuai nama PT
>
> ActiveWorkbook.Close 'Kalau
> udah kesimpen, Tutup Aje
> SrcData.CurrentRegion.AutoFilter
> 'Buang fitur autopilternya
> 'Disini bisa diisi kode buat nyisipin kode mengirimkan email
> kemasing2
> 'tujuan sesuai dengan file hasil export terakhir
> 'Ex:
> 'SendEmail "Email@gw.com" <Email@gw.com>,"Email@lu.net"<Email@lu.net>,"Bro,
> Ini Rekap PT Lu","Liat Aja dilampiran", NamaFile
> 'Kalau memang mau langsung dikirim seperti ini, berarti perlu
> sebuah tabel lagi yang berisi alamat email dan nama PT :D
> Next
>
> MsgBox "Export selesai, Target folder -> " & Fld, vbInformation
>
> Application.DisplayAlerts = True
>
> Application.ScreenUpdating = True
> End Sub
>
>
> Contoh kode sederhana (*Jika email server tidak memerlukan authentikasi
> buat kirim emailnya*) seperti berikut :
>
> Function SendMail(ePengirim As String, eTujuan As String, eSubject As
> String, ByVal eBody As String, eLampiran As String)
> Set oEmail = CreateObject("CDO.Message")
>
> With oEmail
> .From = ePengirim
> .To = eTujuan
> .Subject = eSubject
> .Textbody = eBody
> .AddAttachment eLampiran
>
> With .Configuration.Fields
> .Item(
> "http://schemas.microsoft.com/cdo/configuration/sendusing"<http://schemas.microsoft.com/cdo/configuration/sendusing>)
> = 2
> .Item(
> "http://schemas.microsoft.com/cdo/configuration/smtpserver"<http://schemas.microsoft.com/cdo/configuration/smtpserver>)
> = "192.168.7.7"
> .Item(
> "http://schemas.microsoft.com/cdo/configuration/authenticate"<http://schemas.microsoft.com/cdo/configuration/authenticate>)
> = 1
> .Update
> End With
>
> .Send
> End With
> Set oEmail = Nothing
> End Function
>
> On 04-10-2013 15:53, hendrik karnadi wrote:
>
>
> Jangan putus asa dulu.
> Coba copas lagi macro ini pada VBE Sheet (Module1).
>
> Sub Masukin()
> Dim SrcData As Range, Rng As Range
> Dim cKode As New Collection
> Dim LRow As Long
>
> Application.ScreenUpdating = False
> Sheets("rekap detail").Activate
> Set SrcData = Sheets("rekap detail").Range("E2",
> Range("E2").End(xlDown))
>
> On Error Resume Next
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng)
> Next
>
> For LRow = 1 To cKode.Count
> Set Rng = SrcData.CurrentRegion.Offset(1,
> 0).Resize(SrcData.Rows.Count, 6)
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sheets(cKode.Item(LRow)).Range("A2")
> SrcData.CurrentRegion.AutoFilter
> Next
> Application.ScreenUpdating = True
> End Sub
>
> Mengapa timbul run time error ?
> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>
> Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah macronya
> dicopas di VBE Sheet) maka perlu ditambahkan instruksi warna merah, artinya
> Sheet "rekap detail" harus diaktifkan dulu.
>
> Salam,
> HK
>
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 14:54
> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet [1 Attachment]
>
>
> Dear bro Hendrik,
>
> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro... namanya
> newbe and juga pengen tau bisa gimana caranya.
>
> kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan bisa buat
> ngerjain yang lain.. hehehe
>
> terlampir format data yang biasa digunakan.
>
>
>
> many thanks
> Ahmad H
>
>
>
> ------------------------------
> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
> *Dikirim:* Jumat, 4 Oktober 2013 14:33
> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> Saya sdh tes dan filenya masih disimpan.
>
> Coba kirim file yang ada "run time errornya" karena dengan
> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin memahami dan
> menikmati macro.
>
> JIka anda mau email satu persatu (balasan email anda kepada Miss Jan)
> kenapa ga langung disave sebagai workbook (pada Dir yang sama) per nama PT ?
>
> Salam,
> HK
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 14:02
> *Subject:* Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> Dear Bro Hendrik,
>
> kok nggak bisa ya.. "run time error"
>
> maaf newbe nih... hihihihiihi
>
> mohon bantuannya lagi ya bro...
>
>
> many thanks,
> cheers
> Ahmad H
>
>
>
> ------------------------------
> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
> *Dikirim:* Jumat, 4 Oktober 2013 12:36
> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste (breakdown)
> sheet to sheet
>
>
> Pak De, boleh pinjam codenya ya ?
> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA Module1
> (diambil dari kasus filtering sebelumnya),
>
> Sub Masukin()
> Dim SrcData As Range, Rng As Range
> Dim cKode As New Collection
> Dim LRow As Long
>
> Application.ScreenUpdating = False
> Set SrcData = Sheets("rekap detail").Range("E2", Range("E2
> ").End(xlDown))
>
> On Error Resume Next
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng)
> Next
>
> For LRow = 1 To cKode.Count
> Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count,
> 6)
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sheets(cKode.Item(LRow)).Range("A2")
> SrcData.CurrentRegion.AutoFilter
> Next
> Application.ScreenUpdating = True
> End Sub
>
> Warna merah adalah bagian yang disesuaikan.
>
> Salam,
> HK
>
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 10:57
> *Subject:* [belajar-excel] Need Help melakukan copy paste (breakdown)
> sheet to sheet [1 Attachment]
>
>
> Selamat Pagi,
>
> mudah-mudah an semua anggota di belajar-excel ini selalu mendapatkan
> keberkahan dalam hidup. amin
>
> dalam hal ini saya mau minta mohon bantuannya untuk permasalahan yang
> saya alami,
>
> dikarenakan olah data ini dilakukan 2 hari sekali maka akan sangat
> membantu jika dapat di lakukan otomasi by vb or macro.
>
> dalam 1 file excel terdapat sheet file detail dan beberapa sheet
> breakdown nya.
>
> berikut saya lampirkan file yang dimaksud.
>
> atas perhatian dan bantuannya terima kasih
>
> cheers,
> Ahmad H
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

Fri Oct 4, 2013 8:23 am (PDT) . Posted by:

"hendrik karnadi" hendrikkarnadi

Nah, kalau sdh soal susun-menyusun begini, saya mungkin belum bisa ikut bermain ......

Salam,
HK 

________________________________
From: Mr. Kid <mr.nmkid@gmail.com>
To: BeExcel <belajar-excel@yahoogroups.com>
Sent: Friday, 4 October 2013, 22:09
Subject: Re: Bls: Bls: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet


 
PakD,

script dengan loop add collection dibuat terpisah dengan proses susun output file itu dibandingkan dengan kalau loop add collection diisi sekalian dengan proses susun output file, akan cepat mana ya ? (sorry ndak sempet nyoba).
mungkin bisa lebih cepat kalau dalam add collection ada proses susun output file deh.

Wassalam,
Kid.

2013/10/4 De Premor <de@premor.net>

> 
>ikutan nimbrung ya mas HK
>Buat error yang sebelumnya bisa tanpa berpindah sheet dulu dengan
cara begini
>
>Set SrcData = Sheets("rekap detail").Range("E2",  Sheets("rekap detail").Range("E2").End(xlDown))
>
>berikut kode buat ngefilter per pt, kemudian mengkopy ke sheet baru,
lalu dipindah ke workbook baru, selanjutnya disimpen, setelah itu di
close workbook barunya.
>kalau perlu ditambahi kode buat ngirim email ke masing2 tujuan sekalian, jadi tinggal pencet tombol trus duduk manis atau "ngerjain yang lain" hehehe
>
>Sub ExportPerPT()
>    Dim SrcData As Range, Rng As Range, cKode As New Collection
>    Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile
as String
>   
>    Application.ScreenUpdating = False
>    Application.DisplayAlerts = False
>   
>    Set SrcData = Sheets("rekap detail").Range("E2",
Sheets("rekap detail").Range("E2").End(xlDown))
>   
>    On Error Resume Next 'Proses setelah ini akan menghasilkan error jika ada data duplikat, maka buat error handlernya
>
>    For Each Rng In SrcData
>        cKode.Add Trim(Rng), CStr(Rng)                                          'Buat List Unique Nama2 PT
>    Next
>   
>    Fld = ThisWorkbook.Path & "\Buat
Dikirim\"                                  'Lokasi Pulder buat nyimpen data export'an
>    If Dir(Fld, vbDirectory) = "" Then MkDir
Fld                                'Jika belum ada foldernya, dibuat ajah
>   
>    Set Rng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count,
6)               'Inget2 lokasi Data yang mau dicopy
>
>   
>    For LRow = 1 To cKode.Count
>
        SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=cKode.Item(LRow)  'AutoFilter
>       
Worksheets.Add                                                          'Buat Sheet Baru
>        Set Sh =
ActiveSheet                                                    'Ingat2 Sheet barunya
>        Sh.Name = Left(cKode.Item(LRow),
31)                                    'Ganti Nama Sheet baru menjadi nama PT (Max 31 Karakter)
>        Rng.SpecialCells(xlCellTypeVisible).Copy
Sh.Range("A1")                 'Copy Data Dari Rekap Detail ke Sheet Baru
>       
Sh.Range("A1:F1").EntireColumn.AutoFit                                  'Pas kan lebar kolom
>       
Sh.Move                                                                 'Pindahkan Sheetbaru ke workbook baru
>        NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
>        ActiveWorkbook.SaveAs NamaFile                                          'Simpen workbook barunya sesuai nama PT
>       
ActiveWorkbook.Close                                                    'Kalau udah kesimpen, Tutup Aje
>         SrcData.CurrentRegion.AutoFilter                                                 'Buang fitur autopilternya
>        'Disini bisa diisi kode buat nyisipin kode mengirimkan email kemasing2
>        'tujuan sesuai dengan file hasil export terakhir
>        'Ex:
>        'SendEmail "Email@gw.com","Email@lu.net","Bro, Ini Rekap PT Lu","Liat Aja dilampiran", NamaFile
>        'Kalau memang mau langsung dikirim seperti ini,
berarti perlu sebuah tabel lagi yang berisi alamat email dan
nama PT :D
>    Next
>   
>    MsgBox "Export selesai, Target folder -> " & Fld,
vbInformation
>   
>    Application.DisplayAlerts = True
>
>    Application.ScreenUpdating = True
>End Sub
>
>Contoh kode sederhana (Jika email server tidak memerlukan authentikasi buat kirim emailnya) seperti berikut :
>
>Function SendMail(ePengirim As String, eTujuan As String, eSubject As String, ByVal eBody As String, eLampiran As String)
>    Set oEmail = CreateObject("CDO.Message")
>   
>    With oEmail
>        .From = ePengirim
>        .To = eTujuan
>        .Subject = eSubject
>        .Textbody = eBody
>        .AddAttachment eLampiran
>       
>        With .Configuration.Fields
>           
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
>           
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.7.7"
>           
.Item("http://schemas.microsoft.com/cdo/configuration/authenticate") = 1
>            .Update
>        End With
>       
>        .Send
>    End With
>    Set oEmail = Nothing
>End Function
>
>
>On 04-10-2013 15:53, hendrik karnadi wrote:
>
> 
>>Jangan putus asa dulu.
>>Coba copas lagi macro ini pada VBE Sheet (Module1).
>>
>>
>>Sub Masukin()
>>
>>    Dim SrcData As Range, Rng As Range
>>    Dim cKode As New Collection
>>    Dim LRow As Long
>>
>>
>>    Application.ScreenUpdating = False
>>    Sheets("rekap detail").Activate
>>    Set SrcData = Sheets("rekap detail").Range("E2", Range("E2").End(xlDown))
>>    
>>    On Error Resume Next
>>    For Each Rng In SrcData
>>        cKode.Add Trim(Rng), CStr(Rng)
>>    Next
>>    
>>    For LRow = 1 To cKode.Count
>>        Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count, 6)
>>        SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=cKode.Item(LRow)
>>        Rng.SpecialCells(xlCellTypeVisible).Copy Sheets(cKode.Item(LRow)).Range("A2")
>>        SrcData.CurrentRegion.AutoFilter
>>    Next
>>    Application.ScreenUpdating = True
>>End Sub
>>
>>
>>Mengapa timbul run time error ?
>>Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>>
>>
>>
>>Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah macronya dicopas di VBE Sheet) maka perlu ditambahkan instruksi warna merah, artinya Sheet "rekap detail" harus diaktifkan dulu.
>>
>>
>>Salam,
>>HK
>>
>>
>>
>>
>>
>>________________________________
>> From: Ahmad Habibillah <abiel_1108@yahoo.com>
>>To: belajar-excel@yahoogroups.com
>>Sent: Friday, 4 October 2013, 14:54
>>Subject: Bls: Bls: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet [1 Attachment]
>>
>>
>>
>> 
>>Dear bro Hendrik,
>>
>>
>>sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro... namanya newbe and  juga pengen tau bisa gimana caranya.
>>
>>
>>kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan bisa buat ngerjain yang lain.. hehehe
>>
>>
>>terlampir format data yang biasa digunakan.
>>
>>
>>
>>
>>
>>
>>many thanks
>>Ahmad H
>>
>>
>>
>>
>>
>>________________________________
>> Dari: hendrik karnadi <hendrikkarnadi@yahoo.com>
>>Kepada: "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
>>Dikirim: Jumat, 4 Oktober 2013 14:33
>>Judul: Re: Bls: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet
>>
>>
>>
>> 
>>Saya sdh tes dan filenya masih disimpan.
>>
>>
>>Coba kirim file yang ada "run time errornya" karena dengan mengetahui/memperbaiki kesalahan tersebut kita dapat semakin memahami dan menikmati macro.
>>
>>
>>JIka anda mau email satu persatu (balasan email anda kepada Miss Jan) kenapa ga langung disave sebagai workbook (pada Dir yang sama) per nama PT ?
>>
>>
>>Salam,
>>HK
>>
>>
>>
>>________________________________
>> From: Ahmad Habibillah <abiel_1108@yahoo.com>
>>To: belajar-excel@yahoogroups.com
>>Sent: Friday, 4 October 2013, 14:02
>>Subject: Bls: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet
>>
>>
>>
>> 
>>Dear Bro Hendrik,
>>
>>
>>kok nggak bisa ya.. "run time error"
>>
>>
>>maaf newbe nih... hihihihiihi
>>
>>
>>mohon bantuannya lagi ya bro...
>>
>>
>>
>>
>>many thanks,
>>cheers
>>Ahmad H
>>
>>
>>
>>
>>
>>
>>________________________________
>> Dari: hendrik karnadi <hendrikkarnadi@yahoo.com>
>>Kepada: "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
>>Dikirim: Jumat, 4 Oktober 2013 12:36
>>Judul: Re: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet
>>
>>
>>
>> 
>>Pak De, boleh pinjam codenya ya ?
>>Coba copas macro Pak De Premor di bawah ini pada Sheet VBA Module1 (diambil dari kasus filtering sebelumnya),
>>
>>
>>Sub Masukin()
>>    Dim SrcData As Range, Rng As Range
>>    Dim cKode As New Collection
>>    Dim LRow As Long
>>
>>
>>    Application.ScreenUpdating = False
>>    Set SrcData = Sheets("rekap detail").Range("E2", Range("E2").End(xlDown))
>>    
>>    On Error Resume Next
>>    For Each Rng In SrcData
>>        cKode.Add Trim(Rng), CStr(Rng)
>>    Next
>>    
>>    For LRow = 1 To cKode.Count
>>        Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count, 6)
>>        SrcData.CurrentRegion.AutoFilter Field:=5,
Criteria1:=cKode.Item(LRow)
>>        Rng.SpecialCells(xlCellTypeVisible).Copy
Sheets(cKode.Item(LRow)).Range("A2")
>>        SrcData.CurrentRegion.AutoFilter
>>    Next
>>    Application.ScreenUpdating = True
>>End Sub
>>
>>
>>Warna merah adalah bagian yang disesuaikan.
>>
>>
>>Salam,
>>HK
>>
>>
>>
>>
>>
>>________________________________
>> From: Ahmad Habibillah <abiel_1108@yahoo.com>
>>To: belajar-excel@yahoogroups.com
>>Sent: Friday, 4 October 2013, 10:57
>>Subject: [belajar-excel] Need Help melakukan copy paste (breakdown) sheet to sheet [1 Attachment]
>>
>>
>>
>> 
>>Selamat Pagi,
>>
>>
>>mudah-mudah an semua anggota di belajar-excel ini selalu mendapatkan keberkahan dalam hidup. amin
>>
>>
>>dalam hal ini saya mau minta mohon bantuannya untuk permasalahan yang saya alami,
>>
>>
>>dikarenakan olah data ini dilakukan 2 hari sekali maka akan sangat membantu jika dapat di lakukan otomasi by vb or macro.
>>
>>
>>dalam 1 file excel terdapat sheet file detail dan beberapa sheet breakdown nya.
>>
>>
>>berikut saya lampirkan file yang dimaksud.
>>
>>
>>atas perhatian dan bantuannya terima kasih
>>
>>
>>cheers,
>>Ahmad H
>> 
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>

Fri Oct 4, 2013 9:14 am (PDT) . Posted by:

"De Premor" de.premor

Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg kurang pas yak,
selisihnya kalau dirata-rata 0,2 detik disini :-\

Sub ExportPerPTBaru()
Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As New
Collection
Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As
String, StrRng As String
Dim Timex As Double

Timex = Timer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
detail").Range("E2").End(xlDown))

Fld = ThisWorkbook.Path & "\Buat Dikirin\"
If Dir(Fld, vbDirectory) = "" Then MkDir Fld

Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)

On Error Resume Next
For Each Rng In SrcData
StrRng = Rng.Value
cKode.Add Trim(StrRng), CStr(StrRng)
If Err.Number <> 457 Then
SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
Worksheets.Add
Set Sh = ActiveSheet
Sh.Name = Left(StrRng, 31)
CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
Sh.Range("A1:F1").EntireColumn.AutoFit
Sh.Move
NamaFile = Fld & StrRng & ".xlsx"
ActiveWorkbook.SaveAs NamaFile
ActiveWorkbook.Close
SrcData.CurrentRegion.AutoFilter
End If
Err.Clear
Next

MsgBox "Export selesai dalam waktu " & Timer - Timex & " detik" &
vbCrLf & "Target folder -> " & Fld, vbInformation

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Pada 04/10/2013 22:23, hendrik karnadi menulis:
> Nah, kalau sdh soal susun-menyusun begini, saya mungkin belum bisa
> ikut bermain ......
>
> Salam,
> HK
>
> ----------------------------------------------------------
> *From:* Mr. Kid <mr.nmkid@gmail.com>
> *To:* BeExcel <belajar-excel@yahoogroups.com>
> *Sent:* Friday, 4 October 2013, 22:09
> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help melakukan copy
> paste (breakdown) sheet to sheet
>
> PakD,
>
> script dengan loop add collection dibuat terpisah dengan proses susun
> output file itu dibandingkan dengan kalau loop add collection diisi
> sekalian dengan proses susun output file, akan cepat mana ya ? (sorry
> ndak sempet nyoba).
> mungkin bisa lebih cepat kalau dalam add collection ada proses susun
> output file deh.
>
> Wassalam,
> Kid.
>
>
>
>
>
> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>
> ikutan nimbrung ya mas HK
> Buat error yang sebelumnya bisa tanpa berpindah sheet dulu dengan
> cara begini
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> berikut kode buat ngefilter per pt, kemudian mengkopy ke sheet
> baru, lalu dipindah ke workbook baru, selanjutnya disimpen,
> setelah itu di close workbook barunya.
> /kalau perlu ditambahi kode buat ngirim email ke masing2 tujuan
> sekalian, jadi tinggal pencet tombol trus duduk manis atau
> "//*ngerjain *//*yang lain*//" hehehe/
>
> Sub ExportPerPT()
> Dim SrcData As Range, Rng As Range, cKode As New Collection
> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile as
> String
>
> Application.ScreenUpdating = False
> Application.DisplayAlerts = False
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> On Error Resume Next 'Proses setelah ini akan menghasilkan
> error jika ada data duplikat, maka buat error handlernya
>
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng) 'Buat List Unique Nama2 PT
> Next
>
> Fld = ThisWorkbook.Path & "\Buat Dikirim\" 'Lokasi Pulder buat
> nyimpen data export'an
> If Dir(Fld, vbDirectory) = "" Then MkDir Fld 'Jika belum ada
> foldernya, dibuat ajah
>
> Set Rng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
> 'Inget2 lokasi Data yang mau dicopy
>
>
> For LRow = 1 To cKode.Count
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow) 'AutoFilter
> Worksheets.Add 'Buat Sheet Baru
> Set Sh = ActiveSheet 'Ingat2 Sheet barunya
> Sh.Name = Left(cKode.Item(LRow), 31) 'Ganti Nama Sheet
> baru menjadi nama PT (Max 31 Karakter)
> Rng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1") 'Copy Data
> Dari Rekap Detail ke Sheet Baru
> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas kan lebar kolom
> Sh.Move 'Pindahkan Sheetbaru ke workbook baru
> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile 'Simpen workbook
> barunya sesuai nama PT
> ActiveWorkbook.Close 'Kalau udah kesimpen, Tutup Aje
> SrcData.CurrentRegion.AutoFilter 'Buang fitur autopilternya
> 'Disini bisa diisi kode buat nyisipin kode mengirimkan email
> kemasing2
> 'tujuan sesuai dengan file hasil export terakhir
> 'Ex:
> 'SendEmail "Email@gw.com"
> <mailto:Email@gw.com>,"Email@lu.net" <mailto:Email@lu.net>,"Bro,
> Ini Rekap PT Lu","Liat Aja dilampiran", NamaFile
> 'Kalau memang mau langsung dikirim seperti ini, berarti
> perlu sebuah tabel lagi yang berisi alamat email dan nama PT :D
> Next
>
> MsgBox "Export selesai, Target folder -> " & Fld, vbInformation
>
> Application.DisplayAlerts = True
>
> Application.ScreenUpdating = True
> End Sub
>
>
> Contoh kode sederhana (*Jika email server tidak memerlukan
> authentikasi buat kirim emailnya*) seperti berikut :
>
> Function SendMail(ePengirim As String, eTujuan As String, eSubject
> As String, ByVal eBody As String, eLampiran As String)
> Set oEmail = CreateObject("CDO.Message")
>
> With oEmail
> .From = ePengirim
> .To = eTujuan
> .Subject = eSubject
> .Textbody = eBody
> .AddAttachment eLampiran
>
> With .Configuration.Fields
>
> .Item("http://schemas.microsoft.com/cdo/configuration/sendusing"
> <http://schemas.microsoft.com/cdo/configuration/sendusing>) = 2
>
> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver"
> <http://schemas.microsoft.com/cdo/configuration/smtpserver>) =
> "192.168.7.7"
>
> .Item("http://schemas.microsoft.com/cdo/configuration/authenticate" <http://schemas.microsoft.com/cdo/configuration/authenticate>)
> = 1
> .Update
> End With
>
> .Send
> End With
> Set oEmail = Nothing
> End Function
>
> On 04-10-2013 15:53, hendrik karnadi wrote:
>> Jangan putus asa dulu.
>> Coba copas lagi macro ini pada VBE Sheet (Module1).
>>
>> Sub Masukin()
>> Dim SrcData As Range, Rng As Range
>> Dim cKode As New Collection
>> Dim LRow As Long
>>
>> Application.ScreenUpdating = False
>> Sheets("rekap detail").Activate
>> Set SrcData = Sheets("rekap detail").Range("E2",
>> Range("E2").End(xlDown))
>> On Error Resume Next
>> For Each Rng In SrcData
>> cKode.Add Trim(Rng), CStr(Rng)
>> Next
>> For LRow = 1 To cKode.Count
>> Set Rng = SrcData.CurrentRegion.Offset(1,
>> 0).Resize(SrcData.Rows.Count, 6)
>> SrcData.CurrentRegion.AutoFilter Field:=5,
>> Criteria1:=cKode.Item(LRow)
>> Rng.SpecialCells(xlCellTypeVisible).Copy
>> Sheets(cKode.Item(LRow)).Range("A2")
>> SrcData.CurrentRegion.AutoFilter
>> Next
>> Application.ScreenUpdating = True
>> End Sub
>>
>> Mengapa timbul run time error ?
>> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>>
>> Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah
>> macronya dicopas di VBE Sheet) maka perlu ditambahkan instruksi
>> warna merah, artinya Sheet "rekap detail" harus diaktifkan dulu.
>>
>> Salam,
>> HK
>>
>>
>> ----------------------------------------------------------
>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>> <mailto:abiel_1108@yahoo.com>
>> *To:* belajar-excel@yahoogroups.com
>> <mailto:belajar-excel@yahoogroups.com>
>> *Sent:* Friday, 4 October 2013, 14:54
>> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan copy
>> paste (breakdown) sheet to sheet [1 Attachment]
>>
>> Dear bro Hendrik,
>>
>> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro...
>> namanya newbe and juga pengen tau bisa gimana caranya.
>>
>> kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan
>> bisa buat ngerjain yang lain.. hehehe
>>
>> terlampir format data yang biasa digunakan.
>>
>>
>>
>> many thanks
>> Ahmad H
>>
>>
>>
>> ----------------------------------------------------------
>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>> <mailto:hendrikkarnadi@yahoo.com>
>> *Kepada:* "belajar-excel@yahoogroups.com"
>> <mailto:belajar-excel@yahoogroups.com>
>> <belajar-excel@yahoogroups.com>
>> <mailto:belajar-excel@yahoogroups.com>
>> *Dikirim:* Jumat, 4 Oktober 2013 14:33
>> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet
>>
>> Saya sdh tes dan filenya masih disimpan.
>>
>> Coba kirim file yang ada "run time errornya" karena dengan
>> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin
>> memahami dan menikmati macro.
>>
>> JIka anda mau email satu persatu (balasan email anda kepada Miss
>> Jan) kenapa ga langung disave sebagai workbook (pada Dir yang
>> sama) per nama PT ?
>>
>> Salam,
>> HK
>>
>> ----------------------------------------------------------
>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>> <mailto:abiel_1108@yahoo.com>
>> *To:* belajar-excel@yahoogroups.com
>> <mailto:belajar-excel@yahoogroups.com>
>> *Sent:* Friday, 4 October 2013, 14:02
>> *Subject:* Bls: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet
>>
>> Dear Bro Hendrik,
>>
>> kok nggak bisa ya.. "run time error"
>>
>> maaf newbe nih... hihihihiihi
>>
>> mohon bantuannya lagi ya bro...
>>
>>
>> many thanks,
>> cheers
>> Ahmad H
>>
>>
>>
>> ----------------------------------------------------------
>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>> <mailto:hendrikkarnadi@yahoo.com>
>> *Kepada:* "belajar-excel@yahoogroups.com"
>> <mailto:belajar-excel@yahoogroups.com>
>> <belajar-excel@yahoogroups.com>
>> <mailto:belajar-excel@yahoogroups.com>
>> *Dikirim:* Jumat, 4 Oktober 2013 12:36
>> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet
>>
>> Pak De, boleh pinjam codenya ya ?
>> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA
>> Module1 (diambil dari kasus filtering sebelumnya),
>>
>> Sub Masukin()
>> Dim SrcData As Range, Rng As Range
>> Dim cKode As New Collection
>> Dim LRow As Long
>>
>> Application.ScreenUpdating = False
>> Set SrcData = Sheets("rekap
>> detail").Range("E2", Range("E2").End(xlDown))
>> On Error Resume Next
>> For Each Rng In SrcData
>> cKode.Add Trim(Rng), CStr(Rng)
>> Next
>> For LRow = 1 To cKode.Count
>> Set Rng = SrcData.CurrentRegion.Offset(1,
>> 0).Resize(SrcData.Rows.Count, 6)
>> SrcData.CurrentRegion.AutoFilter Field:=5,
>> Criteria1:=cKode.Item(LRow)
>> Rng.SpecialCells(xlCellTypeVisible).Copy
>> Sheets(cKode.Item(LRow)).Range("A2")
>> SrcData.CurrentRegion.AutoFilter
>> Next
>> Application.ScreenUpdating = True
>> End Sub
>>
>> Warna merah adalah bagian yang disesuaikan.
>>
>> Salam,
>> HK
>>
>>
>> ----------------------------------------------------------
>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>> <mailto:abiel_1108@yahoo.com>
>> *To:* belajar-excel@yahoogroups.com
>> <mailto:belajar-excel@yahoogroups.com>
>> *Sent:* Friday, 4 October 2013, 10:57
>> *Subject:* [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet [1 Attachment]
>>
>> Selamat Pagi,
>>
>> mudah-mudah an semua anggota di belajar-excel ini selalu
>> mendapatkan keberkahan dalam hidup. amin
>>
>> dalam hal ini saya mau minta mohon bantuannya untuk permasalahan
>> yang saya alami,
>>
>> dikarenakan olah data ini dilakukan 2 hari sekali maka akan
>> sangat membantu jika dapat di lakukan otomasi by vb or macro.
>>
>> dalam 1 file excel terdapat sheet file detail dan beberapa sheet
>> breakdown nya.
>>
>> berikut saya lampirkan file yang dimaksud.
>>
>> atas perhatian dan bantuannya terima kasih
>>
>> cheers,
>> Ahmad H
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>
>
>
>
>

Fri Oct 4, 2013 9:29 am (PDT) . Posted by:

"Mr. Kid" nmkid.family@ymail.com

thanks loh ya...

gimana kalo bagian loop jadi :
with err
.clear
For Each Rng In SrcData
StrRng = Rng.Value
cKode.Add Trim(StrRng), CStr(StrRng)
If .Number <> 0 Then
.clear
else
SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
Worksheets.Add
Set Sh = ActiveSheet
Sh.Name = Left(StrRng, 31)
CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
Sh.Range("A1:F1").EntireColumn.AutoFit
Sh.Move
NamaFile = Fld & StrRng & ".xlsx"
ActiveWorkbook.SaveAs NamaFile
ActiveWorkbook.Close
SrcData.CurrentRegion.AutoFilter
End If

Next rng
end with

Coba kalo gini Pak D.

xixixixi.... mumpung ada yang bisa running test... gpp kan ya pakD...

Wassalam,
Kid.

2013/10/4 De Premor <de@premor.net>

> **
>
>
> Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg kurang pas yak,
> selisihnya kalau dirata-rata 0,2 detik disini :-\
>
> Sub ExportPerPTBaru()
> Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As New
> Collection
> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As String,
> StrRng As String
> Dim Timex As Double
>
> Timex = Timer
>
> Application.ScreenUpdating = False
> Application.DisplayAlerts = False
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> Fld = ThisWorkbook.Path & "\Buat Dikirin\"
> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>
> Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>
> On Error Resume Next
> For Each Rng In SrcData
> StrRng = Rng.Value
> cKode.Add Trim(StrRng), CStr(StrRng)
> If Err.Number <> 457 Then
> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
> Worksheets.Add
> Set Sh = ActiveSheet
> Sh.Name = Left(StrRng, 31)
> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
> Sh.Range("A1:F1").EntireColumn.AutoFit
> Sh.Move
> NamaFile = Fld & StrRng & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> ActiveWorkbook.Close
> SrcData.CurrentRegion.AutoFilter
> End If
> Err.Clear
> Next
>
> MsgBox "Export selesai dalam waktu " & Timer - Timex & " detik" &
> vbCrLf & "Target folder -> " & Fld, vbInformation
>
> Application.DisplayAlerts = True
> Application.ScreenUpdating = True
> End Sub
>
> Pada 04/10/2013 22:23, hendrik karnadi menulis:
>
>
> Nah, kalau sdh soal susun-menyusun begini, saya mungkin belum bisa ikut
> bermain ......
>
> Salam,
> HK
>
> ------------------------------
> *From:* Mr. Kid <mr.nmkid@gmail.com> <mr.nmkid@gmail.com>
> *To:* BeExcel <belajar-excel@yahoogroups.com><belajar-excel@yahoogroups.com>
> *Sent:* Friday, 4 October 2013, 22:09
> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> PakD,
>
> script dengan loop add collection dibuat terpisah dengan proses susun
> output file itu dibandingkan dengan kalau loop add collection diisi
> sekalian dengan proses susun output file, akan cepat mana ya ? (sorry ndak
> sempet nyoba).
> mungkin bisa lebih cepat kalau dalam add collection ada proses susun
> output file deh.
>
> Wassalam,
> Kid.
>
>
>
>
>
> 2013/10/4 De Premor <de@premor.net>
>
>
> ikutan nimbrung ya mas HK
> Buat error yang sebelumnya bisa tanpa berpindah sheet dulu dengan cara
> begini
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap detail").
> Range("E2").End(xlDown))
>
> berikut kode buat ngefilter per pt, kemudian mengkopy ke sheet baru, lalu
> dipindah ke workbook baru, selanjutnya disimpen, setelah itu di close
> workbook barunya.
> *kalau perlu ditambahi kode buat ngirim email ke masing2 tujuan sekalian,
> jadi tinggal pencet tombol trus duduk manis atau "**ngerjain **yang lain**"
> hehehe*
>
> Sub ExportPerPT()
> Dim SrcData As Range, Rng As Range, cKode As New Collection
> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile as String
>
> Application.ScreenUpdating = False
> Application.DisplayAlerts = False
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> On Error Resume Next 'Proses setelah ini akan menghasilkan error jika
> ada data duplikat, maka buat error handlernya
>
> For Each Rng In SrcData
> cKode.Add Trim(Rng),
> CStr(Rng) 'Buat List Unique
> Nama2 PT
> Next
>
> Fld = ThisWorkbook.Path & "\Buat
> Dikirim\" 'Lokasi Pulder buat nyimpen
> data export'an
> If Dir(Fld, vbDirectory) = "" Then MkDir
> Fld 'Jika belum ada foldernya, dibuat ajah
>
> Set Rng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count,
> 6) 'Inget2 lokasi Data yang mau dicopy
>
>
> For LRow = 1 To cKode.Count
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow) 'AutoFilter
>
> Worksheets.Add 'Buat
> Sheet Baru
> Set Sh =
> ActiveSheet 'Ingat2
> Sheet barunya
> Sh.Name = Left(cKode.Item(LRow),
> 31) 'Ganti Nama Sheet baru menjadi
> nama PT (Max 31 Karakter)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sh.Range("A1") 'Copy Data Dari Rekap Detail ke Sheet Baru
>
> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas
> kan lebar kolom
>
> Sh.Move 'Pindahkan
> Sheetbaru ke workbook baru
> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> 'Simpen workbook barunya sesuai nama PT
>
> ActiveWorkbook.Close 'Kalau
> udah kesimpen, Tutup Aje
> SrcData.CurrentRegion.AutoFilter
> 'Buang fitur autopilternya
> 'Disini bisa diisi kode buat nyisipin kode mengirimkan email
> kemasing2
> 'tujuan sesuai dengan file hasil export terakhir
> 'Ex:
> 'SendEmail "Email@gw.com" <Email@gw.com>,"Email@lu.net"<Email@lu.net>,"Bro,
> Ini Rekap PT Lu","Liat Aja dilampiran", NamaFile
> 'Kalau memang mau langsung dikirim seperti ini, berarti perlu
> sebuah tabel lagi yang berisi alamat email dan nama PT :D
> Next
>
> MsgBox "Export selesai, Target folder -> " & Fld, vbInformation
>
> Application.DisplayAlerts = True
>
> Application.ScreenUpdating = True
> End Sub
>
>
> Contoh kode sederhana (*Jika email server tidak memerlukan authentikasi
> buat kirim emailnya*) seperti berikut :
>
> Function SendMail(ePengirim As String, eTujuan As String, eSubject As
> String, ByVal eBody As String, eLampiran As String)
> Set oEmail = CreateObject("CDO.Message")
>
> With oEmail
> .From = ePengirim
> .To = eTujuan
> .Subject = eSubject
> .Textbody = eBody
> .AddAttachment eLampiran
>
> With .Configuration.Fields
> .Item(
> "http://schemas.microsoft.com/cdo/configuration/sendusing"<http://schemas.microsoft.com/cdo/configuration/sendusing>)
> = 2
> .Item(
> "http://schemas.microsoft.com/cdo/configuration/smtpserver"<http://schemas.microsoft.com/cdo/configuration/smtpserver>)
> = "192.168.7.7"
> .Item(
> "http://schemas.microsoft.com/cdo/configuration/authenticate"<http://schemas.microsoft.com/cdo/configuration/authenticate>)
> = 1
> .Update
> End With
>
> .Send
> End With
> Set oEmail = Nothing
> End Function
>
> On 04-10-2013 15:53, hendrik karnadi wrote:
>
>
> Jangan putus asa dulu.
> Coba copas lagi macro ini pada VBE Sheet (Module1).
>
> Sub Masukin()
> Dim SrcData As Range, Rng As Range
> Dim cKode As New Collection
> Dim LRow As Long
>
> Application.ScreenUpdating = False
> Sheets("rekap detail").Activate
> Set SrcData = Sheets("rekap detail").Range("E2",
> Range("E2").End(xlDown))
>
> On Error Resume Next
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng)
> Next
>
> For LRow = 1 To cKode.Count
> Set Rng = SrcData.CurrentRegion.Offset(1,
> 0).Resize(SrcData.Rows.Count, 6)
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sheets(cKode.Item(LRow)).Range("A2")
> SrcData.CurrentRegion.AutoFilter
> Next
> Application.ScreenUpdating = True
> End Sub
>
> Mengapa timbul run time error ?
> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>
> Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah macronya
> dicopas di VBE Sheet) maka perlu ditambahkan instruksi warna merah, artinya
> Sheet "rekap detail" harus diaktifkan dulu.
>
> Salam,
> HK
>
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 14:54
> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet [1 Attachment]
>
>
> Dear bro Hendrik,
>
> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro... namanya
> newbe and juga pengen tau bisa gimana caranya.
>
> kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan bisa buat
> ngerjain yang lain.. hehehe
>
> terlampir format data yang biasa digunakan.
>
>
>
> many thanks
> Ahmad H
>
>
>
> ------------------------------
> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
> *Dikirim:* Jumat, 4 Oktober 2013 14:33
> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> Saya sdh tes dan filenya masih disimpan.
>
> Coba kirim file yang ada "run time errornya" karena dengan
> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin memahami dan
> menikmati macro.
>
> JIka anda mau email satu persatu (balasan email anda kepada Miss Jan)
> kenapa ga langung disave sebagai workbook (pada Dir yang sama) per nama PT ?
>
> Salam,
> HK
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 14:02
> *Subject:* Bls: [belajar-excel] Need Help melakukan copy paste
> (breakdown) sheet to sheet
>
>
> Dear Bro Hendrik,
>
> kok nggak bisa ya.. "run time error"
>
> maaf newbe nih... hihihihiihi
>
> mohon bantuannya lagi ya bro...
>
>
> many thanks,
> cheers
> Ahmad H
>
>
>
> ------------------------------
> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
> *Dikirim:* Jumat, 4 Oktober 2013 12:36
> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste (breakdown)
> sheet to sheet
>
>
> Pak De, boleh pinjam codenya ya ?
> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA Module1
> (diambil dari kasus filtering sebelumnya),
>
> Sub Masukin()
> Dim SrcData As Range, Rng As Range
> Dim cKode As New Collection
> Dim LRow As Long
>
> Application.ScreenUpdating = False
> Set SrcData = Sheets("rekap detail").Range("E2", Range("E2
> ").End(xlDown))
>
> On Error Resume Next
> For Each Rng In SrcData
> cKode.Add Trim(Rng), CStr(Rng)
> Next
>
> For LRow = 1 To cKode.Count
> Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count,
> 6)
> SrcData.CurrentRegion.AutoFilter Field:=5,
> Criteria1:=cKode.Item(LRow)
> Rng.SpecialCells(xlCellTypeVisible).Copy
> Sheets(cKode.Item(LRow)).Range("A2")
> SrcData.CurrentRegion.AutoFilter
> Next
> Application.ScreenUpdating = True
> End Sub
>
> Warna merah adalah bagian yang disesuaikan.
>
> Salam,
> HK
>
>
> ------------------------------
> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
> *To:* belajar-excel@yahoogroups.com
> *Sent:* Friday, 4 October 2013, 10:57
> *Subject:* [belajar-excel] Need Help melakukan copy paste (breakdown)
> sheet to sheet [1 Attachment]
>
>
> Selamat Pagi,
>
> mudah-mudah an semua anggota di belajar-excel ini selalu mendapatkan
> keberkahan dalam hidup. amin
>
> dalam hal ini saya mau minta mohon bantuannya untuk permasalahan yang
> saya alami,
>
> dikarenakan olah data ini dilakukan 2 hari sekali maka akan sangat
> membantu jika dapat di lakukan otomasi by vb or macro.
>
> dalam 1 file excel terdapat sheet file detail dan beberapa sheet
> breakdown nya.
>
> berikut saya lampirkan file yang dimaksud.
>
> atas perhatian dan bantuannya terima kasih
>
> cheers,
> Ahmad H
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

Fri Oct 4, 2013 10:00 am (PDT) . Posted by:

"De Premor" de.premor

hehehe
kayaknya sama saja nih, hasil pastinya nga bisa didapat dengan pasti
karena faktor penentunya banyak (ada proses akses IO)
Kalau menurut itung2an kode, setiap kali loop sicode baru akan melakukan
pengecekan error number (1), kalau ketemu error akan ngeclear error (2)

dari potongan kode perbandingan yang *"keliahatannya adil*" ini kalau
ditempat saya masih cepet yg bawah (Sub Diluar) :D

Sub Didalam()
Dim mCol As New Collection, Timex As Double
Dim lRow As Long, nRow As Long, Cnt As Long

Timex = Timer
On Error Resume Next
For lRow = 1 To 100000
For nRow = 1 To 10
mCol.Add nRow, CStr(lRow)
If Err.Number <> 0 Then
Err.Clear
Else
Cnt = Cnt + 1
End If
Next
Next
MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
End Sub

Sub Diluar()
Dim mCol As New Collection, Timex As Double
Dim lRow As Long, nRow As Long, Cnt As Long

Timex = Timer
On Error Resume Next
For lRow = 1 To 100000
For nRow = 1 To 10
mCol.Add nRow, CStr(lRow)
Next
Next

For lRow = 1 To mCol.Count
Cnt = Cnt + 1
Next
MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
End Sub

On 04-10-2013 23:29, Mr. Kid wrote:
> thanks loh ya...
>
> gimana kalo bagian loop jadi :
> with err
> .clear
> For Each Rng In SrcData
> StrRng = Rng.Value
> cKode.Add Trim(StrRng), CStr(StrRng)
> If .Number <> 0 Then
> .clear
> else
> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
> Worksheets.Add
> Set Sh = ActiveSheet
> Sh.Name = Left(StrRng, 31)
> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
> Sh.Range("A1:F1").EntireColumn.AutoFit
> Sh.Move
> NamaFile = Fld & StrRng & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> ActiveWorkbook.Close
> SrcData.CurrentRegion.AutoFilter
> End If
>
> Next rng
> end with
>
> Coba kalo gini Pak D.
>
> xixixixi.... mumpung ada yang bisa running test... gpp kan ya pakD...
>
>
> Wassalam,
> Kid.
>
>
>
> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>
> Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg kurang pas
> yak, selisihnya kalau dirata-rata 0,2 detik disini :-\
>
> Sub ExportPerPTBaru()
> Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As
> New Collection
> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As
> String, StrRng As String
> Dim Timex As Double
>
> Timex = Timer
>
> Application.ScreenUpdating = False
> Application.DisplayAlerts = False
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> Fld = ThisWorkbook.Path & "\Buat Dikirin\"
> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>
> Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>
> On Error Resume Next
> For Each Rng In SrcData
> StrRng = Rng.Value
> cKode.Add Trim(StrRng), CStr(StrRng)
> If Err.Number <> 457 Then
> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
> Worksheets.Add
> Set Sh = ActiveSheet
> Sh.Name = Left(StrRng, 31)
> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
> Sh.Range("A1:F1").EntireColumn.AutoFit
> Sh.Move
> NamaFile = Fld & StrRng & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> ActiveWorkbook.Close
> SrcData.CurrentRegion.AutoFilter
> End If
> Err.Clear
> Next
>
> MsgBox "Export selesai dalam waktu " & Timer - Timex & "
> detik" & vbCrLf & "Target folder -> " & Fld, vbInformation
>
> Application.DisplayAlerts = True
> Application.ScreenUpdating = True
> End Sub
>
> Pada 04/10/2013 22:23, hendrik karnadi menulis:
>> Nah, kalau sdh soal susun-menyusun begini, saya mungkin belum
>> bisa ikut bermain ......
>>
>> Salam,
>> HK
>>
>> ----------------------------------------------------------
>> *From:* Mr. Kid <mr.nmkid@gmail.com> <mailto:mr.nmkid@gmail.com>
>> *To:* BeExcel <belajar-excel@yahoogroups.com>
>> <mailto:belajar-excel@yahoogroups.com>
>> *Sent:* Friday, 4 October 2013, 22:09
>> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help melakukan copy
>> paste (breakdown) sheet to sheet
>>
>> PakD,
>>
>> script dengan loop add collection dibuat terpisah dengan proses
>> susun output file itu dibandingkan dengan kalau loop add
>> collection diisi sekalian dengan proses susun output file, akan
>> cepat mana ya ? (sorry ndak sempet nyoba).
>> mungkin bisa lebih cepat kalau dalam add collection ada proses
>> susun output file deh.
>>
>> Wassalam,
>> Kid.
>>
>>
>>
>>
>>
>> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>>
>> ikutan nimbrung ya mas HK
>> Buat error yang sebelumnya bisa tanpa berpindah sheet dulu
>> dengan cara begini
>>
>> Set SrcData = Sheets("rekap detail").Range("E2",
>> Sheets("rekap detail").Range("E2").End(xlDown))
>>
>> berikut kode buat ngefilter per pt, kemudian mengkopy ke
>> sheet baru, lalu dipindah ke workbook baru, selanjutnya
>> disimpen, setelah itu di close workbook barunya.
>> /kalau perlu ditambahi kode buat ngirim email ke masing2
>> tujuan sekalian, jadi tinggal pencet tombol trus duduk manis
>> atau "//*ngerjain *//*yang lain*//" hehehe/
>>
>> Sub ExportPerPT()
>> Dim SrcData As Range, Rng As Range, cKode As New Collection
>> Dim LRow As Long, Sh As Worksheet, Fld As String,
>> NamaFile as String
>>
>> Application.ScreenUpdating = False
>> Application.DisplayAlerts = False
>>
>> Set SrcData = Sheets("rekap detail").Range("E2",
>> Sheets("rekap detail").Range("E2").End(xlDown))
>>
>> On Error Resume Next 'Proses setelah ini akan
>> menghasilkan error jika ada data duplikat, maka buat error
>> handlernya
>>
>> For Each Rng In SrcData
>> cKode.Add Trim(Rng), CStr(Rng) 'Buat List Unique Nama2 PT
>> Next
>>
>> Fld = ThisWorkbook.Path & "\Buat Dikirim\" 'Lokasi Pulder
>> buat nyimpen data export'an
>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld 'Jika belum
>> ada foldernya, dibuat ajah
>>
>> Set Rng =
>> SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6) 'Inget2
>> lokasi Data yang mau dicopy
>>
>>
>> For LRow = 1 To cKode.Count
>> SrcData.CurrentRegion.AutoFilter Field:=5,
>> Criteria1:=cKode.Item(LRow) 'AutoFilter
>> Worksheets.Add 'Buat Sheet Baru
>> Set Sh = ActiveSheet 'Ingat2 Sheet barunya
>> Sh.Name = Left(cKode.Item(LRow), 31) 'Ganti Nama Sheet baru
>> menjadi nama PT (Max 31 Karakter)
>> Rng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1") 'Copy
>> Data Dari Rekap Detail ke Sheet Baru
>> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas kan lebar kolom
>> Sh.Move 'Pindahkan Sheetbaru ke workbook baru
>> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
>> ActiveWorkbook.SaveAs NamaFile 'Simpen workbook barunya
>> sesuai nama PT
>> ActiveWorkbook.Close 'Kalau udah kesimpen, Tutup Aje
>> SrcData.CurrentRegion.AutoFilter 'Buang fitur autopilternya
>> 'Disini bisa diisi kode buat nyisipin kode mengirimkan
>> email kemasing2
>> 'tujuan sesuai dengan file hasil export terakhir
>> 'Ex:
>> 'SendEmail "Email@gw.com"
>> <mailto:Email@gw.com>,"Email@lu.net"
>> <mailto:Email@lu.net>,"Bro, Ini Rekap PT Lu","Liat Aja
>> dilampiran", NamaFile
>> 'Kalau memang mau langsung dikirim seperti ini,
>> berarti perlu sebuah tabel lagi yang berisi alamat email dan
>> nama PT :D
>> Next
>>
>> MsgBox "Export selesai, Target folder -> " & Fld,
>> vbInformation
>>
>> Application.DisplayAlerts = True
>>
>> Application.ScreenUpdating = True
>> End Sub
>>
>>
>> Contoh kode sederhana (*Jika email server tidak memerlukan
>> authentikasi buat kirim emailnya*) seperti berikut :
>>
>> Function SendMail(ePengirim As String, eTujuan As String,
>> eSubject As String, ByVal eBody As String, eLampiran As String)
>> Set oEmail = CreateObject("CDO.Message")
>>
>> With oEmail
>> .From = ePengirim
>> .To = eTujuan
>> .Subject = eSubject
>> .Textbody = eBody
>> .AddAttachment eLampiran
>>
>> With .Configuration.Fields
>> .Item("http://schemas.microsoft.com/cdo/configuration/sendusing"
>> <http://schemas.microsoft.com/cdo/configuration/sendusing>) = 2
>> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver"
>> <http://schemas.microsoft.com/cdo/configuration/smtpserver>)
>> = "192.168.7.7"
>> .Item("http://schemas.microsoft.com/cdo/configuration/authenticate"
>> <http://schemas.microsoft.com/cdo/configuration/authenticate>) =
>> 1
>> .Update
>> End With
>>
>> .Send
>> End With
>> Set oEmail = Nothing
>> End Function
>>
>> On 04-10-2013 15:53, hendrik karnadi wrote:
>>> Jangan putus asa dulu.
>>> Coba copas lagi macro ini pada VBE Sheet (Module1).
>>>
>>> Sub Masukin()
>>> Dim SrcData As Range, Rng As Range
>>> Dim cKode As New Collection
>>> Dim LRow As Long
>>>
>>> Application.ScreenUpdating = False
>>> Sheets("rekap detail").Activate
>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>> Range("E2").End(xlDown))
>>> On Error Resume Next
>>> For Each Rng In SrcData
>>> cKode.Add Trim(Rng), CStr(Rng)
>>> Next
>>> For LRow = 1 To cKode.Count
>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>> 0).Resize(SrcData.Rows.Count, 6)
>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>> Criteria1:=cKode.Item(LRow)
>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>> Sheets(cKode.Item(LRow)).Range("A2")
>>> SrcData.CurrentRegion.AutoFilter
>>> Next
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>> Mengapa timbul run time error ?
>>> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap
>>> detail".
>>>
>>> Jika anda mau menjalankan macro tsb dari Sheet "rekap"
>>> (setelah macronya dicopas di VBE Sheet) maka perlu
>>> ditambahkan instruksi warna merah, artinya Sheet "rekap
>>> detail" harus diaktifkan dulu.
>>>
>>> Salam,
>>> HK
>>>
>>>
>>> ----------------------------------------------------------
>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>> <mailto:abiel_1108@yahoo.com>
>>> *To:* belajar-excel@yahoogroups.com
>>> <mailto:belajar-excel@yahoogroups.com>
>>> *Sent:* Friday, 4 October 2013, 14:54
>>> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan
>>> copy paste (breakdown) sheet to sheet [1 Attachment]
>>>
>>> Dear bro Hendrik,
>>>
>>> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye
>>> bro... namanya newbe and juga pengen tau bisa gimana caranya.
>>>
>>> kalau itu bisa terealisasi efisiensi waktunya lumayan bro,
>>> kan bisa buat ngerjain yang lain.. hehehe
>>>
>>> terlampir format data yang biasa digunakan.
>>>
>>>
>>>
>>> many thanks
>>> Ahmad H
>>>
>>>
>>>
>>> ----------------------------------------------------------
>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>>> <mailto:hendrikkarnadi@yahoo.com>
>>> *Kepada:* "belajar-excel@yahoogroups.com"
>>> <mailto:belajar-excel@yahoogroups.com>
>>> <belajar-excel@yahoogroups.com>
>>> <mailto:belajar-excel@yahoogroups.com>
>>> *Dikirim:* Jumat, 4 Oktober 2013 14:33
>>> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy
>>> paste (breakdown) sheet to sheet
>>>
>>> Saya sdh tes dan filenya masih disimpan.
>>>
>>> Coba kirim file yang ada "run time errornya" karena dengan
>>> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin
>>> memahami dan menikmati macro.
>>>
>>> JIka anda mau email satu persatu (balasan email anda kepada
>>> Miss Jan) kenapa ga langung disave sebagai workbook (pada
>>> Dir yang sama) per nama PT ?
>>>
>>> Salam,
>>> HK
>>>
>>> ----------------------------------------------------------
>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>> <mailto:abiel_1108@yahoo.com>
>>> *To:* belajar-excel@yahoogroups.com
>>> <mailto:belajar-excel@yahoogroups.com>
>>> *Sent:* Friday, 4 October 2013, 14:02
>>> *Subject:* Bls: [belajar-excel] Need Help melakukan copy
>>> paste (breakdown) sheet to sheet
>>>
>>> Dear Bro Hendrik,
>>>
>>> kok nggak bisa ya.. "run time error"
>>>
>>> maaf newbe nih... hihihihiihi
>>>
>>> mohon bantuannya lagi ya bro...
>>>
>>>
>>> many thanks,
>>> cheers
>>> Ahmad H
>>>
>>>
>>>
>>> ----------------------------------------------------------
>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>>> <mailto:hendrikkarnadi@yahoo.com>
>>> *Kepada:* "belajar-excel@yahoogroups.com"
>>> <mailto:belajar-excel@yahoogroups.com>
>>> <belajar-excel@yahoogroups.com>
>>> <mailto:belajar-excel@yahoogroups.com>
>>> *Dikirim:* Jumat, 4 Oktober 2013 12:36
>>> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste
>>> (breakdown) sheet to sheet
>>>
>>> Pak De, boleh pinjam codenya ya ?
>>> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA
>>> Module1 (diambil dari kasus filtering sebelumnya),
>>>
>>> Sub Masukin()
>>> Dim SrcData As Range, Rng As Range
>>> Dim cKode As New Collection
>>> Dim LRow As Long
>>>
>>> Application.ScreenUpdating = False
>>> Set SrcData = Sheets("rekap
>>> detail").Range("E2", Range("E2").End(xlDown))
>>> On Error Resume Next
>>> For Each Rng In SrcData
>>> cKode.Add Trim(Rng), CStr(Rng)
>>> Next
>>> For LRow = 1 To cKode.Count
>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>> 0).Resize(SrcData.Rows.Count, 6)
>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>> Criteria1:=cKode.Item(LRow)
>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>> Sheets(cKode.Item(LRow)).Range("A2")
>>> SrcData.CurrentRegion.AutoFilter
>>> Next
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>> Warna merah adalah bagian yang disesuaikan.
>>>
>>> Salam,
>>> HK
>>>
>>>
>>> ----------------------------------------------------------
>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>> <mailto:abiel_1108@yahoo.com>
>>> *To:* belajar-excel@yahoogroups.com
>>> <mailto:belajar-excel@yahoogroups.com>
>>> *Sent:* Friday, 4 October 2013, 10:57
>>> *Subject:* [belajar-excel] Need Help melakukan copy paste
>>> (breakdown) sheet to sheet [1 Attachment]
>>>
>>> Selamat Pagi,
>>>
>>> mudah-mudah an semua anggota di belajar-excel ini selalu
>>> mendapatkan keberkahan dalam hidup. amin
>>>
>>> dalam hal ini saya mau minta mohon bantuannya untuk
>>> permasalahan yang saya alami,
>>>
>>> dikarenakan olah data ini dilakukan 2 hari sekali maka akan
>>> sangat membantu jika dapat di lakukan otomasi by vb or macro.
>>>
>>> dalam 1 file excel terdapat sheet file detail dan beberapa
>>> sheet breakdown nya.
>>>
>>> berikut saya lampirkan file yang dimaksud.
>>>
>>> atas perhatian dan bantuannya terima kasih
>>>
>>> cheers,
>>> Ahmad H
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>
>>
>>
>>
>
>
>

Fri Oct 4, 2013 10:07 am (PDT) . Posted by:

"Mr. Kid" nmkid.family@ymail.com

Kalo gitu for each rng nya diganti for lVar=1 to srcdata.count aja
gimana ?

2013/10/4 De Premor <de@premor.net>

> **
>
>
> hehehe
> kayaknya sama saja nih, hasil pastinya nga bisa didapat dengan pasti
> karena faktor penentunya banyak (ada proses akses IO)
> Kalau menurut itung2an kode, setiap kali loop sicode baru akan melakukan
> pengecekan error number (1), kalau ketemu error akan ngeclear error (2)
>
> dari potongan kode perbandingan yang *"keliahatannya adil*" ini kalau
> ditempat saya masih cepet yg bawah (Sub Diluar) :D
>
> Sub Didalam()
> Dim mCol As New Collection, Timex As Double
> Dim lRow As Long, nRow As Long, Cnt As Long
>
> Timex = Timer
> On Error Resume Next
> For lRow = 1 To 100000
> For nRow = 1 To 10
> mCol.Add nRow, CStr(lRow)
> If Err.Number <> 0 Then
> Err.Clear
> Else
> Cnt = Cnt + 1
> End If
> Next
> Next
> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
> End Sub
>
> Sub Diluar()
> Dim mCol As New Collection, Timex As Double
> Dim lRow As Long, nRow As Long, Cnt As Long
>
> Timex = Timer
> On Error Resume Next
> For lRow = 1 To 100000
> For nRow = 1 To 10
> mCol.Add nRow, CStr(lRow)
> Next
> Next
>
> For lRow = 1 To mCol.Count
> Cnt = Cnt + 1
> Next
> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
> End Sub
>
>
> On 04-10-2013 23:29, Mr. Kid wrote:
>
>
> thanks loh ya...
>
> gimana kalo bagian loop jadi :
> with err
> .clear
> For Each Rng In SrcData
> StrRng = Rng.Value
> cKode.Add Trim(StrRng), CStr(StrRng)
> If .Number <> 0 Then
> .clear
> else
> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
> Worksheets.Add
> Set Sh = ActiveSheet
> Sh.Name = Left(StrRng, 31)
> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
> Sh.Range("A1:F1").EntireColumn.AutoFit
> Sh.Move
> NamaFile = Fld & StrRng & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> ActiveWorkbook.Close
> SrcData.CurrentRegion.AutoFilter
> End If
>
> Next rng
> end with
>
> Coba kalo gini Pak D.
>
> xixixixi.... mumpung ada yang bisa running test... gpp kan ya pakD...
>
>
> Wassalam,
> Kid.
>
>
>
> 2013/10/4 De Premor <de@premor.net>
>
>>
>>
>> Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg kurang pas yak,
>> selisihnya kalau dirata-rata 0,2 detik disini :-\
>>
>> Sub ExportPerPTBaru()
>> Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As New
>> Collection
>> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As String,
>> StrRng As String
>> Dim Timex As Double
>>
>> Timex = Timer
>>
>> Application.ScreenUpdating = False
>> Application.DisplayAlerts = False
>>
>> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
>> detail").Range("E2").End(xlDown))
>>
>> Fld = ThisWorkbook.Path & "\Buat Dikirin\"
>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>>
>> Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>>
>> On Error Resume Next
>> For Each Rng In SrcData
>> StrRng = Rng.Value
>> cKode.Add Trim(StrRng), CStr(StrRng)
>> If Err.Number <> 457 Then
>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>> Worksheets.Add
>> Set Sh = ActiveSheet
>> Sh.Name = Left(StrRng, 31)
>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>> Sh.Range("A1:F1").EntireColumn.AutoFit
>> Sh.Move
>> NamaFile = Fld & StrRng & ".xlsx"
>> ActiveWorkbook.SaveAs NamaFile
>> ActiveWorkbook.Close
>> SrcData.CurrentRegion.AutoFilter
>> End If
>> Err.Clear
>> Next
>>
>> MsgBox "Export selesai dalam waktu " & Timer - Timex & " detik" &
>> vbCrLf & "Target folder -> " & Fld, vbInformation
>>
>> Application.DisplayAlerts = True
>> Application.ScreenUpdating = True
>> End Sub
>>
>> Pada 04/10/2013 22:23, hendrik karnadi menulis:
>>
>>
>> Nah, kalau sdh soal susun-menyusun begini, saya mungkin belum bisa ikut
>> bermain ......
>>
>> Salam,
>> HK
>>
>> ------------------------------
>> *From:* Mr. Kid <mr.nmkid@gmail.com> <mr.nmkid@gmail.com>
>> *To:* BeExcel <belajar-excel@yahoogroups.com><belajar-excel@yahoogroups.com>
>> *Sent:* Friday, 4 October 2013, 22:09
>> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet
>>
>>
>> PakD,
>>
>> script dengan loop add collection dibuat terpisah dengan proses susun
>> output file itu dibandingkan dengan kalau loop add collection diisi
>> sekalian dengan proses susun output file, akan cepat mana ya ? (sorry ndak
>> sempet nyoba).
>> mungkin bisa lebih cepat kalau dalam add collection ada proses susun
>> output file deh.
>>
>> Wassalam,
>> Kid.
>>
>>
>>
>>
>>
>> 2013/10/4 De Premor <de@premor.net>
>>
>>
>> ikutan nimbrung ya mas HK
>> Buat error yang sebelumnya bisa tanpa berpindah sheet dulu dengan cara
>> begini
>>
>> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap detail").
>> Range("E2").End(xlDown))
>>
>> berikut kode buat ngefilter per pt, kemudian mengkopy ke sheet baru, lalu
>> dipindah ke workbook baru, selanjutnya disimpen, setelah itu di close
>> workbook barunya.
>> *kalau perlu ditambahi kode buat ngirim email ke masing2 tujuan
>> sekalian, jadi tinggal pencet tombol trus duduk manis atau "**ngerjain **yang
>> lain**" hehehe*
>>
>> Sub ExportPerPT()
>> Dim SrcData As Range, Rng As Range, cKode As New Collection
>> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile as String
>>
>> Application.ScreenUpdating = False
>> Application.DisplayAlerts = False
>>
>> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
>> detail").Range("E2").End(xlDown))
>>
>> On Error Resume Next 'Proses setelah ini akan menghasilkan error
>> jika ada data duplikat, maka buat error handlernya
>>
>> For Each Rng In SrcData
>> cKode.Add Trim(Rng),
>> CStr(Rng) 'Buat List Unique
>> Nama2 PT
>> Next
>>
>> Fld = ThisWorkbook.Path & "\Buat
>> Dikirim\" 'Lokasi Pulder buat nyimpen
>> data export'an
>> If Dir(Fld, vbDirectory) = "" Then MkDir
>> Fld 'Jika belum ada foldernya, dibuat ajah
>>
>> Set Rng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count,
>> 6) 'Inget2 lokasi Data yang mau dicopy
>>
>>
>> For LRow = 1 To cKode.Count
>> SrcData.CurrentRegion.AutoFilter Field:=5,
>> Criteria1:=cKode.Item(LRow) 'AutoFilter
>>
>> Worksheets.Add 'Buat
>> Sheet Baru
>> Set Sh =
>> ActiveSheet 'Ingat2
>> Sheet barunya
>> Sh.Name = Left(cKode.Item(LRow),
>> 31) 'Ganti Nama Sheet baru menjadi
>> nama PT (Max 31 Karakter)
>> Rng.SpecialCells(xlCellTypeVisible).Copy
>> Sh.Range("A1") 'Copy Data Dari Rekap Detail ke Sheet Baru
>>
>> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas
>> kan lebar kolom
>>
>> Sh.Move 'Pindahkan
>> Sheetbaru ke workbook baru
>> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
>> ActiveWorkbook.SaveAs NamaFile
>> 'Simpen workbook barunya sesuai nama PT
>>
>> ActiveWorkbook.Close 'Kalau
>> udah kesimpen, Tutup Aje
>> SrcData.CurrentRegion.AutoFilter
>> 'Buang fitur autopilternya
>> 'Disini bisa diisi kode buat nyisipin kode mengirimkan email
>> kemasing2
>> 'tujuan sesuai dengan file hasil export terakhir
>> 'Ex:
>> 'SendEmail "Email@gw.com" <Email@gw.com>,"Email@lu.net"<Email@lu.net>,"Bro,
>> Ini Rekap PT Lu","Liat Aja dilampiran", NamaFile
>> 'Kalau memang mau langsung dikirim seperti ini, berarti perlu
>> sebuah tabel lagi yang berisi alamat email dan nama PT :D
>> Next
>>
>> MsgBox "Export selesai, Target folder -> " & Fld, vbInformation
>>
>> Application.DisplayAlerts = True
>>
>> Application.ScreenUpdating = True
>> End Sub
>>
>>
>> Contoh kode sederhana (*Jika email server tidak memerlukan authentikasi
>> buat kirim emailnya*) seperti berikut :
>>
>> Function SendMail(ePengirim As String, eTujuan As String, eSubject As
>> String, ByVal eBody As String, eLampiran As String)
>> Set oEmail = CreateObject("CDO.Message")
>>
>> With oEmail
>> .From = ePengirim
>> .To = eTujuan
>> .Subject = eSubject
>> .Textbody = eBody
>> .AddAttachment eLampiran
>>
>> With .Configuration.Fields
>> .Item(
>> "http://schemas.microsoft.com/cdo/configuration/sendusing"<http://schemas.microsoft.com/cdo/configuration/sendusing>)
>> = 2
>> .Item(
>> "http://schemas.microsoft.com/cdo/configuration/smtpserver"<http://schemas.microsoft.com/cdo/configuration/smtpserver>)
>> = "192.168.7.7"
>> .Item(
>> "http://schemas.microsoft.com/cdo/configuration/authenticate"<http://schemas.microsoft.com/cdo/configuration/authenticate>)
>> = 1
>> .Update
>> End With
>>
>> .Send
>> End With
>> Set oEmail = Nothing
>> End Function
>>
>> On 04-10-2013 15:53, hendrik karnadi wrote:
>>
>>
>> Jangan putus asa dulu.
>> Coba copas lagi macro ini pada VBE Sheet (Module1).
>>
>> Sub Masukin()
>> Dim SrcData As Range, Rng As Range
>> Dim cKode As New Collection
>> Dim LRow As Long
>>
>> Application.ScreenUpdating = False
>> Sheets("rekap detail").Activate
>> Set SrcData = Sheets("rekap detail").Range("E2",
>> Range("E2").End(xlDown))
>>
>> On Error Resume Next
>> For Each Rng In SrcData
>> cKode.Add Trim(Rng), CStr(Rng)
>> Next
>>
>> For LRow = 1 To cKode.Count
>> Set Rng = SrcData.CurrentRegion.Offset(1,
>> 0).Resize(SrcData.Rows.Count, 6)
>> SrcData.CurrentRegion.AutoFilter Field:=5,
>> Criteria1:=cKode.Item(LRow)
>> Rng.SpecialCells(xlCellTypeVisible).Copy
>> Sheets(cKode.Item(LRow)).Range("A2")
>> SrcData.CurrentRegion.AutoFilter
>> Next
>> Application.ScreenUpdating = True
>> End Sub
>>
>> Mengapa timbul run time error ?
>> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>>
>> Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah
>> macronya dicopas di VBE Sheet) maka perlu ditambahkan instruksi warna
>> merah, artinya Sheet "rekap detail" harus diaktifkan dulu.
>>
>> Salam,
>> HK
>>
>>
>> ------------------------------
>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
>> *To:* belajar-excel@yahoogroups.com
>> *Sent:* Friday, 4 October 2013, 14:54
>> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet [1 Attachment]
>>
>>
>> Dear bro Hendrik,
>>
>> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro... namanya
>> newbe and juga pengen tau bisa gimana caranya.
>>
>> kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan bisa
>> buat ngerjain yang lain.. hehehe
>>
>> terlampir format data yang biasa digunakan.
>>
>>
>>
>> many thanks
>> Ahmad H
>>
>>
>>
>> ------------------------------
>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
>> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
>> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
>> *Dikirim:* Jumat, 4 Oktober 2013 14:33
>> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet
>>
>>
>> Saya sdh tes dan filenya masih disimpan.
>>
>> Coba kirim file yang ada "run time errornya" karena dengan
>> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin memahami dan
>> menikmati macro.
>>
>> JIka anda mau email satu persatu (balasan email anda kepada Miss Jan)
>> kenapa ga langung disave sebagai workbook (pada Dir yang sama) per nama PT ?
>>
>> Salam,
>> HK
>>
>> ------------------------------
>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
>> *To:* belajar-excel@yahoogroups.com
>> *Sent:* Friday, 4 October 2013, 14:02
>> *Subject:* Bls: [belajar-excel] Need Help melakukan copy paste
>> (breakdown) sheet to sheet
>>
>>
>> Dear Bro Hendrik,
>>
>> kok nggak bisa ya.. "run time error"
>>
>> maaf newbe nih... hihihihiihi
>>
>> mohon bantuannya lagi ya bro...
>>
>>
>> many thanks,
>> cheers
>> Ahmad H
>>
>>
>>
>> ------------------------------
>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
>> *Kepada:* "belajar-excel@yahoogroups.com" <belajar-excel@yahoogroups.com>
>> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
>> *Dikirim:* Jumat, 4 Oktober 2013 12:36
>> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste (breakdown)
>> sheet to sheet
>>
>>
>> Pak De, boleh pinjam codenya ya ?
>> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA Module1
>> (diambil dari kasus filtering sebelumnya),
>>
>> Sub Masukin()
>> Dim SrcData As Range, Rng As Range
>> Dim cKode As New Collection
>> Dim LRow As Long
>>
>> Application.ScreenUpdating = False
>> Set SrcData = Sheets("rekap detail").Range("E2", Range("E2
>> ").End(xlDown))
>>
>> On Error Resume Next
>> For Each Rng In SrcData
>> cKode.Add Trim(Rng), CStr(Rng)
>> Next
>>
>> For LRow = 1 To cKode.Count
>> Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count,
>> 6)
>> SrcData.CurrentRegion.AutoFilter Field:=5,
>> Criteria1:=cKode.Item(LRow)
>> Rng.SpecialCells(xlCellTypeVisible).Copy
>> Sheets(cKode.Item(LRow)).Range("A2")
>> SrcData.CurrentRegion.AutoFilter
>> Next
>> Application.ScreenUpdating = True
>> End Sub
>>
>> Warna merah adalah bagian yang disesuaikan.
>>
>> Salam,
>> HK
>>
>>
>> ------------------------------
>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
>> *To:* belajar-excel@yahoogroups.com
>> *Sent:* Friday, 4 October 2013, 10:57
>> *Subject:* [belajar-excel] Need Help melakukan copy paste (breakdown)
>> sheet to sheet [1 Attachment]
>>
>>
>> Selamat Pagi,
>>
>> mudah-mudah an semua anggota di belajar-excel ini selalu mendapatkan
>> keberkahan dalam hidup. amin
>>
>> dalam hal ini saya mau minta mohon bantuannya untuk permasalahan yang
>> saya alami,
>>
>> dikarenakan olah data ini dilakukan 2 hari sekali maka akan sangat
>> membantu jika dapat di lakukan otomasi by vb or macro.
>>
>> dalam 1 file excel terdapat sheet file detail dan beberapa sheet
>> breakdown nya.
>>
>> berikut saya lampirkan file yang dimaksud.
>>
>> atas perhatian dan bantuannya terima kasih
>>
>> cheers,
>> Ahmad H
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>>
>
>
>

Fri Oct 4, 2013 10:17 am (PDT) . Posted by:

"De Premor" de.premor

Di contoh kode yang barusan sudah begitu dia, dan hasilnya lebih cepat
yang terpisah, dalam 100k x 10 kalkulasi, beda 0,15 s/d 0,17 detik di
Dell Optiplex 390, dan 0,95'an detik di Netbook yang lagi kepanasan :D

On 05-10-2013 0:06, Mr. Kid wrote:
> Kalo gitu for each rng nya diganti for lVar=1 to srcdata.count aja
> gimana ?
>
>
>
> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>
> hehehe
> kayaknya sama saja nih, hasil pastinya nga bisa didapat dengan
> pasti karena faktor penentunya banyak (ada proses akses IO)
> Kalau menurut itung2an kode, setiap kali loop sicode baru akan
> melakukan pengecekan error number (1), kalau ketemu error akan
> ngeclear error (2)
>
> dari potongan kode perbandingan yang *"keliahatannya adil*" ini
> kalau ditempat saya masih cepet yg bawah (Sub Diluar) :D
>
> Sub Didalam()
> Dim mCol As New Collection, Timex As Double
> Dim lRow As Long, nRow As Long, Cnt As Long
>
> Timex = Timer
> On Error Resume Next
> For lRow = 1 To 100000
> For nRow = 1 To 10
> mCol.Add nRow, CStr(lRow)
> If Err.Number <> 0 Then
> Err.Clear
> Else
> Cnt = Cnt + 1
> End If
> Next
> Next
> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
> End Sub
>
> Sub Diluar()
> Dim mCol As New Collection, Timex As Double
> Dim lRow As Long, nRow As Long, Cnt As Long
>
> Timex = Timer
> On Error Resume Next
> For lRow = 1 To 100000
> For nRow = 1 To 10
> mCol.Add nRow, CStr(lRow)
> Next
> Next
>
> For lRow = 1 To mCol.Count
> Cnt = Cnt + 1
> Next
> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
> End Sub
>
>
> On 04-10-2013 23:29, Mr. Kid wrote:
>
>> thanks loh ya...
>>
>> gimana kalo bagian loop jadi :
>> with err
>> .clear
>> For Each Rng In SrcData
>> StrRng = Rng.Value
>> cKode.Add Trim(StrRng), CStr(StrRng)
>> If .Number <> 0 Then
>> .clear
>> else
>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>> Worksheets.Add
>> Set Sh = ActiveSheet
>> Sh.Name = Left(StrRng, 31)
>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>> Sh.Range("A1:F1").EntireColumn.AutoFit
>> Sh.Move
>> NamaFile = Fld & StrRng & ".xlsx"
>> ActiveWorkbook.SaveAs NamaFile
>> ActiveWorkbook.Close
>> SrcData.CurrentRegion.AutoFilter
>> End If
>>
>> Next rng
>> end with
>>
>> Coba kalo gini Pak D.
>>
>> xixixixi.... mumpung ada yang bisa running test... gpp kan ya pakD...
>>
>>
>> Wassalam,
>> Kid.
>>
>>
>>
>> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>>
>> Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg
>> kurang pas yak, selisihnya kalau dirata-rata 0,2 detik disini
>> :-\
>>
>> Sub ExportPerPTBaru()
>> Dim SrcData As Range, Rng As Range, CopyRng As Range,
>> cKode As New Collection
>> Dim LRow As Long, Sh As Worksheet, Fld As String,
>> NamaFile As String, StrRng As String
>> Dim Timex As Double
>>
>> Timex = Timer
>>
>> Application.ScreenUpdating = False
>> Application.DisplayAlerts = False
>>
>> Set SrcData = Sheets("rekap detail").Range("E2",
>> Sheets("rekap detail").Range("E2").End(xlDown))
>>
>> Fld = ThisWorkbook.Path & "\Buat Dikirin\"
>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>>
>> Set CopyRng =
>> SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>>
>> On Error Resume Next
>> For Each Rng In SrcData
>> StrRng = Rng.Value
>> cKode.Add Trim(StrRng), CStr(StrRng)
>> If Err.Number <> 457 Then
>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>> Worksheets.Add
>> Set Sh = ActiveSheet
>> Sh.Name = Left(StrRng, 31)
>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>> Sh.Range("A1:F1").EntireColumn.AutoFit
>> Sh.Move
>> NamaFile = Fld & StrRng & ".xlsx"
>> ActiveWorkbook.SaveAs NamaFile
>> ActiveWorkbook.Close
>> SrcData.CurrentRegion.AutoFilter
>> End If
>> Err.Clear
>> Next
>>
>> MsgBox "Export selesai dalam waktu " & Timer - Timex & "
>> detik" & vbCrLf & "Target folder -> " & Fld, vbInformation
>>
>> Application.DisplayAlerts = True
>> Application.ScreenUpdating = True
>> End Sub
>>
>> Pada 04/10/2013 22:23, hendrik karnadi menulis:
>>> Nah, kalau sdh soal susun-menyusun begini, saya mungkin
>>> belum bisa ikut bermain ......
>>>
>>> Salam,
>>> HK
>>>
>>> ----------------------------------------------------------
>>> *From:* Mr. Kid <mr.nmkid@gmail.com> <mailto:mr.nmkid@gmail.com>
>>> *To:* BeExcel <belajar-excel@yahoogroups.com>
>>> <mailto:belajar-excel@yahoogroups.com>
>>> *Sent:* Friday, 4 October 2013, 22:09
>>> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help melakukan
>>> copy paste (breakdown) sheet to sheet
>>>
>>> PakD,
>>>
>>> script dengan loop add collection dibuat terpisah dengan
>>> proses susun output file itu dibandingkan dengan kalau loop
>>> add collection diisi sekalian dengan proses susun output
>>> file, akan cepat mana ya ? (sorry ndak sempet nyoba).
>>> mungkin bisa lebih cepat kalau dalam add collection ada
>>> proses susun output file deh.
>>>
>>> Wassalam,
>>> Kid.
>>>
>>>
>>>
>>>
>>>
>>> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>>>
>>> ikutan nimbrung ya mas HK
>>> Buat error yang sebelumnya bisa tanpa berpindah sheet
>>> dulu dengan cara begini
>>>
>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>> Sheets("rekap detail").Range("E2").End(xlDown))
>>>
>>> berikut kode buat ngefilter per pt, kemudian mengkopy ke
>>> sheet baru, lalu dipindah ke workbook baru, selanjutnya
>>> disimpen, setelah itu di close workbook barunya.
>>> /kalau perlu ditambahi kode buat ngirim email ke masing2
>>> tujuan sekalian, jadi tinggal pencet tombol trus duduk
>>> manis atau "//*ngerjain *//*yang lain*//" hehehe/
>>>
>>> Sub ExportPerPT()
>>> Dim SrcData As Range, Rng As Range, cKode As New
>>> Collection
>>> Dim LRow As Long, Sh As Worksheet, Fld As String,
>>> NamaFile as String
>>>
>>> Application.ScreenUpdating = False
>>> Application.DisplayAlerts = False
>>>
>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>> Sheets("rekap detail").Range("E2").End(xlDown))
>>>
>>> On Error Resume Next 'Proses setelah ini akan
>>> menghasilkan error jika ada data duplikat, maka buat
>>> error handlernya
>>>
>>> For Each Rng In SrcData
>>> cKode.Add Trim(Rng), CStr(Rng) 'Buat List Unique Nama2 PT
>>> Next
>>>
>>> Fld = ThisWorkbook.Path & "\Buat Dikirim\" 'Lokasi
>>> Pulder buat nyimpen data export'an
>>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld 'Jika
>>> belum ada foldernya, dibuat ajah
>>>
>>> Set Rng =
>>> SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>>> 'Inget2 lokasi Data yang mau dicopy
>>>
>>>
>>> For LRow = 1 To cKode.Count
>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>> Criteria1:=cKode.Item(LRow) 'AutoFilter
>>> Worksheets.Add 'Buat Sheet Baru
>>> Set Sh = ActiveSheet 'Ingat2 Sheet barunya
>>> Sh.Name = Left(cKode.Item(LRow), 31) 'Ganti Nama Sheet
>>> baru menjadi nama PT (Max 31 Karakter)
>>> Rng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>>> 'Copy Data Dari Rekap Detail ke Sheet Baru
>>> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas kan lebar kolom
>>> Sh.Move 'Pindahkan Sheetbaru ke workbook baru
>>> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
>>> ActiveWorkbook.SaveAs NamaFile 'Simpen workbook barunya
>>> sesuai nama PT
>>> ActiveWorkbook.Close 'Kalau udah kesimpen, Tutup Aje
>>> SrcData.CurrentRegion.AutoFilter 'Buang fitur autopilternya
>>> 'Disini bisa diisi kode buat nyisipin kode
>>> mengirimkan email kemasing2
>>> 'tujuan sesuai dengan file hasil export terakhir
>>> 'Ex:
>>> 'SendEmail "Email@gw.com"
>>> <mailto:Email@gw.com>,"Email@lu.net"
>>> <mailto:Email@lu.net>,"Bro, Ini Rekap PT Lu","Liat Aja
>>> dilampiran", NamaFile
>>> 'Kalau memang mau langsung dikirim seperti ini,
>>> berarti perlu sebuah tabel lagi yang berisi alamat email
>>> dan nama PT :D
>>> Next
>>>
>>> MsgBox "Export selesai, Target folder -> " & Fld,
>>> vbInformation
>>>
>>> Application.DisplayAlerts = True
>>>
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>>
>>> Contoh kode sederhana (*Jika email server tidak
>>> memerlukan authentikasi buat kirim emailnya*) seperti
>>> berikut :
>>>
>>> Function SendMail(ePengirim As String, eTujuan As
>>> String, eSubject As String, ByVal eBody As String,
>>> eLampiran As String)
>>> Set oEmail = CreateObject("CDO.Message")
>>>
>>> With oEmail
>>> .From = ePengirim
>>> .To = eTujuan
>>> .Subject = eSubject
>>> .Textbody = eBody
>>> .AddAttachment eLampiran
>>>
>>> With .Configuration.Fields
>>> .Item("http://schemas.microsoft.com/cdo/configuration/sendusing"
>>> <http://schemas.microsoft.com/cdo/configuration/sendusing>)
>>> = 2
>>> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver"
>>> <http://schemas.microsoft.com/cdo/configuration/smtpserver>)
>>> = "192.168.7.7"
>>> .Item("http://schemas.microsoft.com/cdo/configuration/authenticate"
>>> <http://schemas.microsoft.com/cdo/configuration/authenticate>)
>>> = 1
>>> .Update
>>> End With
>>>
>>> .Send
>>> End With
>>> Set oEmail = Nothing
>>> End Function
>>>
>>> On 04-10-2013 15:53, hendrik karnadi wrote:
>>>> Jangan putus asa dulu.
>>>> Coba copas lagi macro ini pada VBE Sheet (Module1).
>>>>
>>>> Sub Masukin()
>>>> Dim SrcData As Range, Rng As Range
>>>> Dim cKode As New Collection
>>>> Dim LRow As Long
>>>>
>>>> Application.ScreenUpdating = False
>>>> Sheets("rekap detail").Activate
>>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>>> Range("E2").End(xlDown))
>>>> On Error Resume Next
>>>> For Each Rng In SrcData
>>>> cKode.Add Trim(Rng), CStr(Rng)
>>>> Next
>>>> For LRow = 1 To cKode.Count
>>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>>> 0).Resize(SrcData.Rows.Count, 6)
>>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>>> Criteria1:=cKode.Item(LRow)
>>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>>> Sheets(cKode.Item(LRow)).Range("A2")
>>>> SrcData.CurrentRegion.AutoFilter
>>>> Next
>>>> Application.ScreenUpdating = True
>>>> End Sub
>>>>
>>>> Mengapa timbul run time error ?
>>>> Waktu menjalankan macro, anda tidak berada pada Sheet
>>>> "rekap detail".
>>>>
>>>> Jika anda mau menjalankan macro tsb dari Sheet "rekap"
>>>> (setelah macronya dicopas di VBE Sheet) maka perlu
>>>> ditambahkan instruksi warna merah, artinya Sheet "rekap
>>>> detail" harus diaktifkan dulu.
>>>>
>>>> Salam,
>>>> HK
>>>>
>>>>
>>>> ----------------------------------------------------------
>>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>>> <mailto:abiel_1108@yahoo.com>
>>>> *To:* belajar-excel@yahoogroups.com
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> *Sent:* Friday, 4 October 2013, 14:54
>>>> *Subject:* Bls: Bls: [belajar-excel] Need Help
>>>> melakukan copy paste (breakdown) sheet to sheet [1
>>>> Attachment]
>>>>
>>>> Dear bro Hendrik,
>>>>
>>>> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye
>>>> bro... namanya newbe and juga pengen tau bisa gimana
>>>> caranya.
>>>>
>>>> kalau itu bisa terealisasi efisiensi waktunya lumayan
>>>> bro, kan bisa buat ngerjain yang lain.. hehehe
>>>>
>>>> terlampir format data yang biasa digunakan.
>>>>
>>>>
>>>>
>>>> many thanks
>>>> Ahmad H
>>>>
>>>>
>>>>
>>>> ----------------------------------------------------------
>>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>>>> <mailto:hendrikkarnadi@yahoo.com>
>>>> *Kepada:* "belajar-excel@yahoogroups.com"
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> <belajar-excel@yahoogroups.com>
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> *Dikirim:* Jumat, 4 Oktober 2013 14:33
>>>> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan
>>>> copy paste (breakdown) sheet to sheet
>>>>
>>>> Saya sdh tes dan filenya masih disimpan.
>>>>
>>>> Coba kirim file yang ada "run time errornya" karena
>>>> dengan mengetahui/memperbaiki kesalahan tersebut kita
>>>> dapat semakin memahami dan menikmati macro.
>>>>
>>>> JIka anda mau email satu persatu (balasan email anda
>>>> kepada Miss Jan) kenapa ga langung disave sebagai
>>>> workbook (pada Dir yang sama) per nama PT ?
>>>>
>>>> Salam,
>>>> HK
>>>>
>>>> ----------------------------------------------------------
>>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>>> <mailto:abiel_1108@yahoo.com>
>>>> *To:* belajar-excel@yahoogroups.com
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> *Sent:* Friday, 4 October 2013, 14:02
>>>> *Subject:* Bls: [belajar-excel] Need Help melakukan
>>>> copy paste (breakdown) sheet to sheet
>>>>
>>>> Dear Bro Hendrik,
>>>>
>>>> kok nggak bisa ya.. "run time error"
>>>>
>>>> maaf newbe nih... hihihihiihi
>>>>
>>>> mohon bantuannya lagi ya bro...
>>>>
>>>>
>>>> many thanks,
>>>> cheers
>>>> Ahmad H
>>>>
>>>>
>>>>
>>>> ----------------------------------------------------------
>>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>>>> <mailto:hendrikkarnadi@yahoo.com>
>>>> *Kepada:* "belajar-excel@yahoogroups.com"
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> <belajar-excel@yahoogroups.com>
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> *Dikirim:* Jumat, 4 Oktober 2013 12:36
>>>> *Judul:* Re: [belajar-excel] Need Help melakukan copy
>>>> paste (breakdown) sheet to sheet
>>>>
>>>> Pak De, boleh pinjam codenya ya ?
>>>> Coba copas macro Pak De Premor di bawah ini pada Sheet
>>>> VBA Module1 (diambil dari kasus filtering sebelumnya),
>>>>
>>>> Sub Masukin()
>>>> Dim SrcData As Range, Rng As Range
>>>> Dim cKode As New Collection
>>>> Dim LRow As Long
>>>>
>>>> Application.ScreenUpdating = False
>>>> Set SrcData = Sheets("rekap
>>>> detail").Range("E2", Range("E2").End(xlDown))
>>>> On Error Resume Next
>>>> For Each Rng In SrcData
>>>> cKode.Add Trim(Rng), CStr(Rng)
>>>> Next
>>>> For LRow = 1 To cKode.Count
>>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>>> 0).Resize(SrcData.Rows.Count, 6)
>>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>>> Criteria1:=cKode.Item(LRow)
>>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>>> Sheets(cKode.Item(LRow)).Range("A2")
>>>> SrcData.CurrentRegion.AutoFilter
>>>> Next
>>>> Application.ScreenUpdating = True
>>>> End Sub
>>>>
>>>> Warna merah adalah bagian yang disesuaikan.
>>>>
>>>> Salam,
>>>> HK
>>>>
>>>>
>>>> ----------------------------------------------------------
>>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>>> <mailto:abiel_1108@yahoo.com>
>>>> *To:* belajar-excel@yahoogroups.com
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> *Sent:* Friday, 4 October 2013, 10:57
>>>> *Subject:* [belajar-excel] Need Help melakukan copy
>>>> paste (breakdown) sheet to sheet [1 Attachment]
>>>>
>>>> Selamat Pagi,
>>>>
>>>> mudah-mudah an semua anggota di belajar-excel ini
>>>> selalu mendapatkan keberkahan dalam hidup. amin
>>>>
>>>> dalam hal ini saya mau minta mohon bantuannya untuk
>>>> permasalahan yang saya alami,
>>>>
>>>> dikarenakan olah data ini dilakukan 2 hari sekali maka
>>>> akan sangat membantu jika dapat di lakukan otomasi by
>>>> vb or macro.
>>>>
>>>> dalam 1 file excel terdapat sheet file detail dan
>>>> beberapa sheet breakdown nya.
>>>>
>>>> berikut saya lampirkan file yang dimaksud.
>>>>
>>>> atas perhatian dan bantuannya terima kasih
>>>>
>>>> cheers,
>>>> Ahmad H
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>>
>>>
>>>
>>>
>>>
>>
>>
>
>
>

Fri Oct 4, 2013 11:10 am (PDT) . Posted by:

"Mr. Kid" nmkid.family@ymail.com

Aku coba kok beda ya.

File terlampir.
Sepertinya posisi set StrRng yang bikin beda.
Kalau record lebih dari 5K apalagi vendor unsorted akan lebih terasa lagi
(tes 10K vendor unsorted selisih 4s).
Kalau di prosedur runner si script bawah di run pertama, selisihnya cuma
dikit.

Script :
Public Sub ExportPerPTBaruKid(Optional bState As Boolean = False)
Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As New
Collection
Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As String,
StrRng As String
Dim lCurRow As Long

Timex = Timer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
detail").Range("E2").End(xlDown))

Fld = ThisWorkbook.Path & "\_BuatDikirim_\"

If Dir(Fld, vbDirectory) = "" Then MkDir Fld

Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)

On Error Resume Next
With Err
.Clear

For lCurRow = 1 To SrcData.Count
cKode.Add Trim$(SrcData(lCurRow).Value),
CStr(SrcData(lCurRow).Value)
If .Number <> 0 Then
.Clear
Else
StrRng = SrcData(lCurRow).Value
CopyRng.AutoFilter Field:=5, Criteria1:=StrRng
Worksheets.Add
Set Sh = ActiveSheet
Sh.Name = Left(StrRng, 31)
CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
Sh.Range("A:F").AutoFit
Sh.Move
NamaFile = Fld & StrRng & ".xlsx"
ActiveWorkbook.SaveAs NamaFile
ActiveWorkbook.Close
CopyRng.AutoFilter
End If
Next lCurRow
End With
Timex = Timer - Timex

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

ya wis lah...
thanks ya PakD...
Kapan-kapan kita coba karakteristik Do While yak...
ojo kapok loh..

Wassalam,
Kid.

2013/10/5 De Premor <de@premor.net>

> **
>
>
> Di contoh kode yang barusan sudah begitu dia, dan hasilnya lebih cepat
> yang terpisah, dalam 100k x 10 kalkulasi, beda 0,15 s/d 0,17 detik di Dell
> Optiplex 390, dan 0,95'an detik di Netbook yang lagi kepanasan :D
>
> On 05-10-2013 0:06, Mr. Kid wrote:
>
>
> Kalo gitu for each rng nya diganti for lVar=1 to srcdata.count aja
> gimana ?
>
>
>
> 2013/10/4 De Premor <de@premor.net>
>
>>
>>
>> hehehe
>> kayaknya sama saja nih, hasil pastinya nga bisa didapat dengan pasti
>> karena faktor penentunya banyak (ada proses akses IO)
>> Kalau menurut itung2an kode, setiap kali loop sicode baru akan melakukan
>> pengecekan error number (1), kalau ketemu error akan ngeclear error (2)
>>
>> dari potongan kode perbandingan yang *"keliahatannya adil*" ini kalau
>> ditempat saya masih cepet yg bawah (Sub Diluar) :D
>>
>> Sub Didalam()
>> Dim mCol As New Collection, Timex As Double
>> Dim lRow As Long, nRow As Long, Cnt As Long
>>
>> Timex = Timer
>> On Error Resume Next
>> For lRow = 1 To 100000
>> For nRow = 1 To 10
>> mCol.Add nRow, CStr(lRow)
>> If Err.Number <> 0 Then
>> Err.Clear
>> Else
>> Cnt = Cnt + 1
>> End If
>> Next
>> Next
>> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
>> End Sub
>>
>> Sub Diluar()
>> Dim mCol As New Collection, Timex As Double
>> Dim lRow As Long, nRow As Long, Cnt As Long
>>
>> Timex = Timer
>> On Error Resume Next
>> For lRow = 1 To 100000
>> For nRow = 1 To 10
>> mCol.Add nRow, CStr(lRow)
>> Next
>> Next
>>
>> For lRow = 1 To mCol.Count
>> Cnt = Cnt + 1
>> Next
>> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
>> End Sub
>>
>>
>> On 04-10-2013 23:29, Mr. Kid wrote:
>>
>>
>> thanks loh ya...
>>
>> gimana kalo bagian loop jadi :
>> with err
>> .clear
>> For Each Rng In SrcData
>> StrRng = Rng.Value
>> cKode.Add Trim(StrRng), CStr(StrRng)
>> If .Number <> 0 Then
>> .clear
>> else
>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>> Worksheets.Add
>> Set Sh = ActiveSheet
>> Sh.Name = Left(StrRng, 31)
>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>> Sh.Range("A1:F1").EntireColumn.AutoFit
>> Sh.Move
>> NamaFile = Fld & StrRng & ".xlsx"
>> ActiveWorkbook.SaveAs NamaFile
>> ActiveWorkbook.Close
>> SrcData.CurrentRegion.AutoFilter
>> End If
>>
>> Next rng
>> end with
>>
>> Coba kalo gini Pak D.
>>
>> xixixixi.... mumpung ada yang bisa running test... gpp kan ya pakD...
>>
>>
>> Wassalam,
>> Kid.
>>
>>
>>
>> 2013/10/4 De Premor <de@premor.net>
>>
>>>
>>>
>>> Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg kurang pas yak,
>>> selisihnya kalau dirata-rata 0,2 detik disini :-\
>>>
>>> Sub ExportPerPTBaru()
>>> Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As New
>>> Collection
>>> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As
>>> String, StrRng As String
>>> Dim Timex As Double
>>>
>>> Timex = Timer
>>>
>>> Application.ScreenUpdating = False
>>> Application.DisplayAlerts = False
>>>
>>> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
>>> detail").Range("E2").End(xlDown))
>>>
>>> Fld = ThisWorkbook.Path & "\Buat Dikirin\"
>>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>>>
>>> Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>>>
>>> On Error Resume Next
>>> For Each Rng In SrcData
>>> StrRng = Rng.Value
>>> cKode.Add Trim(StrRng), CStr(StrRng)
>>> If Err.Number <> 457 Then
>>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>>> Worksheets.Add
>>> Set Sh = ActiveSheet
>>> Sh.Name = Left(StrRng, 31)
>>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>>> Sh.Range("A1:F1").EntireColumn.AutoFit
>>> Sh.Move
>>> NamaFile = Fld & StrRng & ".xlsx"
>>> ActiveWorkbook.SaveAs NamaFile
>>> ActiveWorkbook.Close
>>> SrcData.CurrentRegion.AutoFilter
>>> End If
>>> Err.Clear
>>> Next
>>>
>>> MsgBox "Export selesai dalam waktu " & Timer - Timex & " detik" &
>>> vbCrLf & "Target folder -> " & Fld, vbInformation
>>>
>>> Application.DisplayAlerts = True
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>> Pada 04/10/2013 22:23, hendrik karnadi menulis:
>>>
>>>
>>> Nah, kalau sdh soal susun-menyusun begini, saya mungkin belum bisa
>>> ikut bermain ......
>>>
>>> Salam,
>>> HK
>>>
>>> ------------------------------
>>> *From:* Mr. Kid <mr.nmkid@gmail.com> <mr.nmkid@gmail.com>
>>> *To:* BeExcel <belajar-excel@yahoogroups.com><belajar-excel@yahoogroups.com>
>>> *Sent:* Friday, 4 October 2013, 22:09
>>> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help melakukan copy paste
>>> (breakdown) sheet to sheet
>>>
>>>
>>> PakD,
>>>
>>> script dengan loop add collection dibuat terpisah dengan proses susun
>>> output file itu dibandingkan dengan kalau loop add collection diisi
>>> sekalian dengan proses susun output file, akan cepat mana ya ? (sorry ndak
>>> sempet nyoba).
>>> mungkin bisa lebih cepat kalau dalam add collection ada proses susun
>>> output file deh.
>>>
>>> Wassalam,
>>> Kid.
>>>
>>>
>>>
>>>
>>>
>>> 2013/10/4 De Premor <de@premor.net>
>>>
>>>
>>> ikutan nimbrung ya mas HK
>>> Buat error yang sebelumnya bisa tanpa berpindah sheet dulu dengan cara
>>> begini
>>>
>>> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
>>> detail").Range("E2").End(xlDown))
>>>
>>> berikut kode buat ngefilter per pt, kemudian mengkopy ke sheet baru,
>>> lalu dipindah ke workbook baru, selanjutnya disimpen, setelah itu di close
>>> workbook barunya.
>>> *kalau perlu ditambahi kode buat ngirim email ke masing2 tujuan
>>> sekalian, jadi tinggal pencet tombol trus duduk manis atau "**ngerjain *
>>> *yang lain**" hehehe*
>>>
>>> Sub ExportPerPT()
>>> Dim SrcData As Range, Rng As Range, cKode As New Collection
>>> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile as String
>>>
>>> Application.ScreenUpdating = False
>>> Application.DisplayAlerts = False
>>>
>>> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
>>> detail").Range("E2").End(xlDown))
>>>
>>> On Error Resume Next 'Proses setelah ini akan menghasilkan error
>>> jika ada data duplikat, maka buat error handlernya
>>>
>>> For Each Rng In SrcData
>>> cKode.Add Trim(Rng),
>>> CStr(Rng) 'Buat List Unique
>>> Nama2 PT
>>> Next
>>>
>>> Fld = ThisWorkbook.Path & "\Buat
>>> Dikirim\" 'Lokasi Pulder buat nyimpen
>>> data export'an
>>> If Dir(Fld, vbDirectory) = "" Then MkDir
>>> Fld 'Jika belum ada foldernya, dibuat
>>> ajah
>>>
>>> Set Rng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count,
>>> 6) 'Inget2 lokasi Data yang mau dicopy
>>>
>>>
>>> For LRow = 1 To cKode.Count
>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>> Criteria1:=cKode.Item(LRow) 'AutoFilter
>>>
>>> Worksheets.Add 'Buat
>>> Sheet Baru
>>> Set Sh =
>>> ActiveSheet 'Ingat2
>>> Sheet barunya
>>> Sh.Name = Left(cKode.Item(LRow),
>>> 31) 'Ganti Nama Sheet baru menjadi
>>> nama PT (Max 31 Karakter)
>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>> Sh.Range("A1") 'Copy Data Dari Rekap Detail ke Sheet
>>> Baru
>>>
>>> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas
>>> kan lebar kolom
>>>
>>> Sh.Move 'Pindahkan
>>> Sheetbaru ke workbook baru
>>> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
>>> ActiveWorkbook.SaveAs NamaFile
>>> 'Simpen workbook barunya sesuai nama PT
>>>
>>> ActiveWorkbook.Close 'Kalau
>>> udah kesimpen, Tutup Aje
>>> SrcData.CurrentRegion.AutoFilter
>>> 'Buang fitur autopilternya
>>> 'Disini bisa diisi kode buat nyisipin kode mengirimkan email
>>> kemasing2
>>> 'tujuan sesuai dengan file hasil export terakhir
>>> 'Ex:
>>> 'SendEmail "Email@gw.com" <Email@gw.com>,"Email@lu.net"<Email@lu.net>,"Bro,
>>> Ini Rekap PT Lu","Liat Aja dilampiran", NamaFile
>>> 'Kalau memang mau langsung dikirim seperti ini, berarti perlu
>>> sebuah tabel lagi yang berisi alamat email dan nama PT :D
>>> Next
>>>
>>> MsgBox "Export selesai, Target folder -> " & Fld, vbInformation
>>>
>>> Application.DisplayAlerts = True
>>>
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>>
>>> Contoh kode sederhana (*Jika email server tidak memerlukan authentikasi
>>> buat kirim emailnya*) seperti berikut :
>>>
>>> Function SendMail(ePengirim As String, eTujuan As String, eSubject As
>>> String, ByVal eBody As String, eLampiran As String)
>>> Set oEmail = CreateObject("CDO.Message")
>>>
>>> With oEmail
>>> .From = ePengirim
>>> .To = eTujuan
>>> .Subject = eSubject
>>> .Textbody = eBody
>>> .AddAttachment eLampiran
>>>
>>> With .Configuration.Fields
>>> .Item(
>>> "http://schemas.microsoft.com/cdo/configuration/sendusing"<http://schemas.microsoft.com/cdo/configuration/sendusing>)
>>> = 2
>>> .Item(
>>> "http://schemas.microsoft.com/cdo/configuration/smtpserver"<http://schemas.microsoft.com/cdo/configuration/smtpserver>)
>>> = "192.168.7.7"
>>> .Item(
>>> "http://schemas.microsoft.com/cdo/configuration/authenticate"<http://schemas.microsoft.com/cdo/configuration/authenticate>)
>>> = 1
>>> .Update
>>> End With
>>>
>>> .Send
>>> End With
>>> Set oEmail = Nothing
>>> End Function
>>>
>>> On 04-10-2013 15:53, hendrik karnadi wrote:
>>>
>>>
>>> Jangan putus asa dulu.
>>> Coba copas lagi macro ini pada VBE Sheet (Module1).
>>>
>>> Sub Masukin()
>>> Dim SrcData As Range, Rng As Range
>>> Dim cKode As New Collection
>>> Dim LRow As Long
>>>
>>> Application.ScreenUpdating = False
>>> Sheets("rekap detail").Activate
>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>> Range("E2").End(xlDown))
>>>
>>> On Error Resume Next
>>> For Each Rng In SrcData
>>> cKode.Add Trim(Rng), CStr(Rng)
>>> Next
>>>
>>> For LRow = 1 To cKode.Count
>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>> 0).Resize(SrcData.Rows.Count, 6)
>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>> Criteria1:=cKode.Item(LRow)
>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>> Sheets(cKode.Item(LRow)).Range("A2")
>>> SrcData.CurrentRegion.AutoFilter
>>> Next
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>> Mengapa timbul run time error ?
>>> Waktu menjalankan macro, anda tidak berada pada Sheet "rekap detail".
>>>
>>> Jika anda mau menjalankan macro tsb dari Sheet "rekap" (setelah
>>> macronya dicopas di VBE Sheet) maka perlu ditambahkan instruksi warna
>>> merah, artinya Sheet "rekap detail" harus diaktifkan dulu.
>>>
>>> Salam,
>>> HK
>>>
>>>
>>> ------------------------------
>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
>>> *To:* belajar-excel@yahoogroups.com
>>> *Sent:* Friday, 4 October 2013, 14:54
>>> *Subject:* Bls: Bls: [belajar-excel] Need Help melakukan copy paste
>>> (breakdown) sheet to sheet [1 Attachment]
>>>
>>>
>>> Dear bro Hendrik,
>>>
>>> sekali lagi mohon bantuannya ya bro, mohon dimaklumi ye bro... namanya
>>> newbe and juga pengen tau bisa gimana caranya.
>>>
>>> kalau itu bisa terealisasi efisiensi waktunya lumayan bro, kan bisa
>>> buat ngerjain yang lain.. hehehe
>>>
>>> terlampir format data yang biasa digunakan.
>>>
>>>
>>>
>>> many thanks
>>> Ahmad H
>>>
>>>
>>>
>>> ------------------------------
>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
>>> *Kepada:* "belajar-excel@yahoogroups.com"<belajar-excel@yahoogroups.com>
>>> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
>>> *Dikirim:* Jumat, 4 Oktober 2013 14:33
>>> *Judul:* Re: Bls: [belajar-excel] Need Help melakukan copy paste
>>> (breakdown) sheet to sheet
>>>
>>>
>>> Saya sdh tes dan filenya masih disimpan.
>>>
>>> Coba kirim file yang ada "run time errornya" karena dengan
>>> mengetahui/memperbaiki kesalahan tersebut kita dapat semakin memahami dan
>>> menikmati macro.
>>>
>>> JIka anda mau email satu persatu (balasan email anda kepada Miss Jan)
>>> kenapa ga langung disave sebagai workbook (pada Dir yang sama) per nama PT ?
>>>
>>> Salam,
>>> HK
>>>
>>> ------------------------------
>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
>>> *To:* belajar-excel@yahoogroups.com
>>> *Sent:* Friday, 4 October 2013, 14:02
>>> *Subject:* Bls: [belajar-excel] Need Help melakukan copy paste
>>> (breakdown) sheet to sheet
>>>
>>>
>>> Dear Bro Hendrik,
>>>
>>> kok nggak bisa ya.. "run time error"
>>>
>>> maaf newbe nih... hihihihiihi
>>>
>>> mohon bantuannya lagi ya bro...
>>>
>>>
>>> many thanks,
>>> cheers
>>> Ahmad H
>>>
>>>
>>>
>>> ------------------------------
>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com><hendrikkarnadi@yahoo.com>
>>> *Kepada:* "belajar-excel@yahoogroups.com"<belajar-excel@yahoogroups.com>
>>> <belajar-excel@yahoogroups.com> <belajar-excel@yahoogroups.com>
>>> *Dikirim:* Jumat, 4 Oktober 2013 12:36
>>> *Judul:* Re: [belajar-excel] Need Help melakukan copy paste (breakdown)
>>> sheet to sheet
>>>
>>>
>>> Pak De, boleh pinjam codenya ya ?
>>> Coba copas macro Pak De Premor di bawah ini pada Sheet VBA Module1
>>> (diambil dari kasus filtering sebelumnya),
>>>
>>> Sub Masukin()
>>> Dim SrcData As Range, Rng As Range
>>> Dim cKode As New Collection
>>> Dim LRow As Long
>>>
>>> Application.ScreenUpdating = False
>>> Set SrcData = Sheets("rekap detail").Range("E2", Range("E2
>>> ").End(xlDown))
>>>
>>> On Error Resume Next
>>> For Each Rng In SrcData
>>> cKode.Add Trim(Rng), CStr(Rng)
>>> Next
>>>
>>> For LRow = 1 To cKode.Count
>>> Set Rng = SrcData.CurrentRegion.Offset(1, 0).Resize(SrcData.Rows.Count,
>>> 6)
>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>> Criteria1:=cKode.Item(LRow)
>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>> Sheets(cKode.Item(LRow)).Range("A2")
>>> SrcData.CurrentRegion.AutoFilter
>>> Next
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>> Warna merah adalah bagian yang disesuaikan.
>>>
>>> Salam,
>>> HK
>>>
>>>
>>> ------------------------------
>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com> <abiel_1108@yahoo.com>
>>> *To:* belajar-excel@yahoogroups.com
>>> *Sent:* Friday, 4 October 2013, 10:57
>>> *Subject:* [belajar-excel] Need Help melakukan copy paste (breakdown)
>>> sheet to sheet [1 Attachment]
>>>
>>>
>>> Selamat Pagi,
>>>
>>> mudah-mudah an semua anggota di belajar-excel ini selalu mendapatkan
>>> keberkahan dalam hidup. amin
>>>
>>> dalam hal ini saya mau minta mohon bantuannya untuk permasalahan yang
>>> saya alami,
>>>
>>> dikarenakan olah data ini dilakukan 2 hari sekali maka akan sangat
>>> membantu jika dapat di lakukan otomasi by vb or macro.
>>>
>>> dalam 1 file excel terdapat sheet file detail dan beberapa sheet
>>> breakdown nya.
>>>
>>> berikut saya lampirkan file yang dimaksud.
>>>
>>> atas perhatian dan bantuannya terima kasih
>>>
>>> cheers,
>>> Ahmad H
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>
>>
>
>
>

Fri Oct 4, 2013 11:17 am (PDT) . Posted by:

"De Premor" de.premor

hehhe, monggo mas Kid, tinimbang nganggur tongkrongan ra jelas, kan
memang mending ngoprek kode :D
Sugeng Enjang Mas... (gak kerasa udah pagi, hiks...)

Pada 05/10/2013 1:10, Mr. Kid menulis:
> Aku coba kok beda ya.
>
> File terlampir.
> Sepertinya posisi set StrRng yang bikin beda.
> Kalau record lebih dari 5K apalagi vendor unsorted akan lebih terasa
> lagi (tes 10K vendor unsorted selisih 4s).
> Kalau di prosedur runner si script bawah di run pertama, selisihnya
> cuma dikit.
>
> Script :
> Public Sub ExportPerPTBaruKid(Optional bState As Boolean = False)
> Dim SrcData As Range, Rng As Range, CopyRng As Range, cKode As New
> Collection
> Dim LRow As Long, Sh As Worksheet, Fld As String, NamaFile As
> String, StrRng As String
> Dim lCurRow As Long
>
> Timex = Timer
>
>
> Application.ScreenUpdating = False
> Application.DisplayAlerts = False
>
> Set SrcData = Sheets("rekap detail").Range("E2", Sheets("rekap
> detail").Range("E2").End(xlDown))
>
> Fld = ThisWorkbook.Path & "\_BuatDikirim_\"
>
> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>
> Set CopyRng = SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>
>
> On Error Resume Next
> With Err
> .Clear
>
> For lCurRow = 1 To SrcData.Count
> cKode.Add Trim$(SrcData(lCurRow).Value),
> CStr(SrcData(lCurRow).Value)
> If .Number <> 0 Then
> .Clear
> Else
> StrRng = SrcData(lCurRow).Value
> CopyRng.AutoFilter Field:=5, Criteria1:=StrRng
> Worksheets.Add
> Set Sh = ActiveSheet
> Sh.Name = Left(StrRng, 31)
> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
> Sh.Range("A:F").AutoFit
> Sh.Move
> NamaFile = Fld & StrRng & ".xlsx"
> ActiveWorkbook.SaveAs NamaFile
> ActiveWorkbook.Close
> CopyRng.AutoFilter
> End If
> Next lCurRow
> End With
> Timex = Timer - Timex
>
> Application.DisplayAlerts = True
> Application.ScreenUpdating = True
> End Sub
>
>
> ya wis lah...
> thanks ya PakD...
> Kapan-kapan kita coba karakteristik Do While yak...
> ojo kapok loh..
>
> Wassalam,
> Kid.
>
>
>
>
>
> 2013/10/5 De Premor <de@premor.net <mailto:de@premor.net>>
>
> Di contoh kode yang barusan sudah begitu dia, dan hasilnya lebih
> cepat yang terpisah, dalam 100k x 10 kalkulasi, beda 0,15 s/d 0,17
> detik di Dell Optiplex 390, dan 0,95'an detik di Netbook yang
> lagi kepanasan :D
>
> On 05-10-2013 0:06, Mr. Kid wrote:
>> Kalo gitu for each rng nya diganti for lVar=1 to srcdata.count aja
>> gimana ?
>>
>>
>>
>> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>>
>> hehehe
>> kayaknya sama saja nih, hasil pastinya nga bisa didapat
>> dengan pasti karena faktor penentunya banyak (ada proses
>> akses IO)
>> Kalau menurut itung2an kode, setiap kali loop sicode baru
>> akan melakukan pengecekan error number (1), kalau ketemu
>> error akan ngeclear error (2)
>>
>> dari potongan kode perbandingan yang *"keliahatannya adil*"
>> ini kalau ditempat saya masih cepet yg bawah (Sub Diluar) :D
>>
>> Sub Didalam()
>> Dim mCol As New Collection, Timex As Double
>> Dim lRow As Long, nRow As Long, Cnt As Long
>>
>> Timex = Timer
>> On Error Resume Next
>> For lRow = 1 To 100000
>> For nRow = 1 To 10
>> mCol.Add nRow, CStr(lRow)
>> If Err.Number <> 0 Then
>> Err.Clear
>> Else
>> Cnt = Cnt + 1
>> End If
>> Next
>> Next
>> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
>> End Sub
>>
>> Sub Diluar()
>> Dim mCol As New Collection, Timex As Double
>> Dim lRow As Long, nRow As Long, Cnt As Long
>>
>> Timex = Timer
>> On Error Resume Next
>> For lRow = 1 To 100000
>> For nRow = 1 To 10
>> mCol.Add nRow, CStr(lRow)
>> Next
>> Next
>>
>> For lRow = 1 To mCol.Count
>> Cnt = Cnt + 1
>> Next
>> MsgBox Cnt & vbCrLf & Timer - Timex & " detik"
>> End Sub
>>
>>
>> On 04-10-2013 23:29, Mr. Kid wrote:
>>
>>> thanks loh ya...
>>>
>>> gimana kalo bagian loop jadi :
>>> with err
>>> .clear
>>> For Each Rng In SrcData
>>> StrRng = Rng.Value
>>> cKode.Add Trim(StrRng), CStr(StrRng)
>>> If .Number <> 0 Then
>>> .clear
>>> else
>>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>>> Worksheets.Add
>>> Set Sh = ActiveSheet
>>> Sh.Name = Left(StrRng, 31)
>>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>>> Sh.Range("A1:F1").EntireColumn.AutoFit
>>> Sh.Move
>>> NamaFile = Fld & StrRng & ".xlsx"
>>> ActiveWorkbook.SaveAs NamaFile
>>> ActiveWorkbook.Close
>>> SrcData.CurrentRegion.AutoFilter
>>> End If
>>>
>>> Next rng
>>> end with
>>>
>>> Coba kalo gini Pak D.
>>>
>>> xixixixi.... mumpung ada yang bisa running test... gpp kan
>>> ya pakD...
>>>
>>>
>>> Wassalam,
>>> Kid.
>>>
>>>
>>>
>>> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>>>
>>> Setelah dicoba2 tetep cepet yang lama ya, apa caraku yg
>>> kurang pas yak, selisihnya kalau dirata-rata 0,2 detik
>>> disini :-\
>>>
>>> Sub ExportPerPTBaru()
>>> Dim SrcData As Range, Rng As Range, CopyRng As
>>> Range, cKode As New Collection
>>> Dim LRow As Long, Sh As Worksheet, Fld As String,
>>> NamaFile As String, StrRng As String
>>> Dim Timex As Double
>>>
>>> Timex = Timer
>>>
>>> Application.ScreenUpdating = False
>>> Application.DisplayAlerts = False
>>>
>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>> Sheets("rekap detail").Range("E2").End(xlDown))
>>>
>>> Fld = ThisWorkbook.Path & "\Buat Dikirin\"
>>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>>>
>>> Set CopyRng =
>>> SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>>>
>>> On Error Resume Next
>>> For Each Rng In SrcData
>>> StrRng = Rng.Value
>>> cKode.Add Trim(StrRng), CStr(StrRng)
>>> If Err.Number <> 457 Then
>>> SrcData.CurrentRegion.AutoFilter Field:=5, Criteria1:=StrRng
>>> Worksheets.Add
>>> Set Sh = ActiveSheet
>>> Sh.Name = Left(StrRng, 31)
>>> CopyRng.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
>>> Sh.Range("A1:F1").EntireColumn.AutoFit
>>> Sh.Move
>>> NamaFile = Fld & StrRng & ".xlsx"
>>> ActiveWorkbook.SaveAs NamaFile
>>> ActiveWorkbook.Close
>>> SrcData.CurrentRegion.AutoFilter
>>> End If
>>> Err.Clear
>>> Next
>>>
>>> MsgBox "Export selesai dalam waktu " & Timer - Timex
>>> & " detik" & vbCrLf & "Target folder -> " & Fld,
>>> vbInformation
>>>
>>> Application.DisplayAlerts = True
>>> Application.ScreenUpdating = True
>>> End Sub
>>>
>>> Pada 04/10/2013 22:23, hendrik karnadi menulis:
>>>> Nah, kalau sdh soal susun-menyusun begini, saya mungkin
>>>> belum bisa ikut bermain ......
>>>>
>>>> Salam,
>>>> HK
>>>>
>>>> ----------------------------------------------------------
>>>> *From:* Mr. Kid <mr.nmkid@gmail.com>
>>>> <mailto:mr.nmkid@gmail.com>
>>>> *To:* BeExcel <belajar-excel@yahoogroups.com>
>>>> <mailto:belajar-excel@yahoogroups.com>
>>>> *Sent:* Friday, 4 October 2013, 22:09
>>>> *Subject:* Re: Bls: Bls: [belajar-excel] Need Help
>>>> melakukan copy paste (breakdown) sheet to sheet
>>>>
>>>> PakD,
>>>>
>>>> script dengan loop add collection dibuat terpisah
>>>> dengan proses susun output file itu dibandingkan dengan
>>>> kalau loop add collection diisi sekalian dengan proses
>>>> susun output file, akan cepat mana ya ? (sorry ndak
>>>> sempet nyoba).
>>>> mungkin bisa lebih cepat kalau dalam add collection ada
>>>> proses susun output file deh.
>>>>
>>>> Wassalam,
>>>> Kid.
>>>>
>>>>
>>>>
>>>>
>>>>
>>>> 2013/10/4 De Premor <de@premor.net <mailto:de@premor.net>>
>>>>
>>>> ikutan nimbrung ya mas HK
>>>> Buat error yang sebelumnya bisa tanpa berpindah
>>>> sheet dulu dengan cara begini
>>>>
>>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>>> Sheets("rekap detail").Range("E2").End(xlDown))
>>>>
>>>> berikut kode buat ngefilter per pt, kemudian
>>>> mengkopy ke sheet baru, lalu dipindah ke workbook
>>>> baru, selanjutnya disimpen, setelah itu di close
>>>> workbook barunya.
>>>> /kalau perlu ditambahi kode buat ngirim email ke
>>>> masing2 tujuan sekalian, jadi tinggal pencet tombol
>>>> trus duduk manis atau "//*ngerjain *//*yang
>>>> lain*//" hehehe/
>>>>
>>>> Sub ExportPerPT()
>>>> Dim SrcData As Range, Rng As Range, cKode As
>>>> New Collection
>>>> Dim LRow As Long, Sh As Worksheet, Fld As
>>>> String, NamaFile as String
>>>>
>>>> Application.ScreenUpdating = False
>>>> Application.DisplayAlerts = False
>>>>
>>>> Set SrcData = Sheets("rekap
>>>> detail").Range("E2", Sheets("rekap
>>>> detail").Range("E2").End(xlDown))
>>>>
>>>> On Error Resume Next 'Proses setelah ini akan
>>>> menghasilkan error jika ada data duplikat, maka
>>>> buat error handlernya
>>>>
>>>> For Each Rng In SrcData
>>>> cKode.Add Trim(Rng), CStr(Rng) 'Buat List Unique
>>>> Nama2 PT
>>>> Next
>>>>
>>>> Fld = ThisWorkbook.Path & "\Buat Dikirim\"
>>>> 'Lokasi Pulder buat nyimpen data export'an
>>>> If Dir(Fld, vbDirectory) = "" Then MkDir Fld
>>>> 'Jika belum ada foldernya, dibuat ajah
>>>>
>>>> Set Rng =
>>>> SrcData.CurrentRegion.Resize(SrcData.Rows.Count, 6)
>>>> 'Inget2 lokasi Data yang mau dicopy
>>>>
>>>>
>>>> For LRow = 1 To cKode.Count
>>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>>> Criteria1:=cKode.Item(LRow) 'AutoFilter
>>>> Worksheets.Add 'Buat Sheet Baru
>>>> Set Sh = ActiveSheet 'Ingat2 Sheet barunya
>>>> Sh.Name = Left(cKode.Item(LRow), 31) 'Ganti Nama
>>>> Sheet baru menjadi nama PT (Max 31 Karakter)
>>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>>> Sh.Range("A1") 'Copy Data Dari Rekap Detail ke
>>>> Sheet Baru
>>>> Sh.Range("A1:F1").EntireColumn.AutoFit 'Pas kan
>>>> lebar kolom
>>>> Sh.Move 'Pindahkan Sheetbaru ke workbook baru
>>>> NamaFile = Fld & ActiveSheet.[E2] & ".xlsx"
>>>> ActiveWorkbook.SaveAs NamaFile 'Simpen workbook
>>>> barunya sesuai nama PT
>>>> ActiveWorkbook.Close 'Kalau udah kesimpen, Tutup Aje
>>>> SrcData.CurrentRegion.AutoFilter 'Buang fitur
>>>> autopilternya
>>>> 'Disini bisa diisi kode buat nyisipin kode
>>>> mengirimkan email kemasing2
>>>> 'tujuan sesuai dengan file hasil export terakhir
>>>> 'Ex:
>>>> 'SendEmail "Email@gw.com"
>>>> <mailto:Email@gw.com>,"Email@lu.net"
>>>> <mailto:Email@lu.net>,"Bro, Ini Rekap PT Lu","Liat
>>>> Aja dilampiran", NamaFile
>>>> 'Kalau memang mau langsung dikirim seperti
>>>> ini, berarti perlu sebuah tabel lagi yang berisi
>>>> alamat email dan nama PT :D
>>>> Next
>>>>
>>>> MsgBox "Export selesai, Target folder -> " &
>>>> Fld, vbInformation
>>>>
>>>> Application.DisplayAlerts = True
>>>>
>>>> Application.ScreenUpdating = True
>>>> End Sub
>>>>
>>>>
>>>> Contoh kode sederhana (*Jika email server tidak
>>>> memerlukan authentikasi buat kirim emailnya*)
>>>> seperti berikut :
>>>>
>>>> Function SendMail(ePengirim As String, eTujuan As
>>>> String, eSubject As String, ByVal eBody As String,
>>>> eLampiran As String)
>>>> Set oEmail = CreateObject("CDO.Message")
>>>>
>>>> With oEmail
>>>> .From = ePengirim
>>>> .To = eTujuan
>>>> .Subject = eSubject
>>>> .Textbody = eBody
>>>> .AddAttachment eLampiran
>>>>
>>>> With .Configuration.Fields
>>>> .Item("http://schemas.microsoft.com/cdo/configuration/sendusing"
>>>> <http://schemas.microsoft.com/cdo/configuration/sendusing>)
>>>> = 2
>>>> .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver"
>>>> <http://schemas.microsoft.com/cdo/configuration/smtpserver>)
>>>> = "192.168.7.7"
>>>> .Item("http://schemas.microsoft.com/cdo/configuration/authenticate"
>>>> <http://schemas.microsoft.com/cdo/configuration/authenticate>)
>>>> = 1
>>>> .Update
>>>> End With
>>>>
>>>> .Send
>>>> End With
>>>> Set oEmail = Nothing
>>>> End Function
>>>>
>>>> On 04-10-2013 15:53, hendrik karnadi wrote:
>>>>> Jangan putus asa dulu.
>>>>> Coba copas lagi macro ini pada VBE Sheet (Module1).
>>>>>
>>>>> Sub Masukin()
>>>>> Dim SrcData As Range, Rng As Range
>>>>> Dim cKode As New Collection
>>>>> Dim LRow As Long
>>>>>
>>>>> Application.ScreenUpdating = False
>>>>> Sheets("rekap detail").Activate
>>>>> Set SrcData = Sheets("rekap detail").Range("E2",
>>>>> Range("E2").End(xlDown))
>>>>> On Error Resume Next
>>>>> For Each Rng In SrcData
>>>>> cKode.Add Trim(Rng), CStr(Rng)
>>>>> Next
>>>>> For LRow = 1 To cKode.Count
>>>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>>>> 0).Resize(SrcData.Rows.Count, 6)
>>>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>>>> Criteria1:=cKode.Item(LRow)
>>>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>>>> Sheets(cKode.Item(LRow)).Range("A2")
>>>>> SrcData.CurrentRegion.AutoFilter
>>>>> Next
>>>>> Application.ScreenUpdating = True
>>>>> End Sub
>>>>>
>>>>> Mengapa timbul run time error ?
>>>>> Waktu menjalankan macro, anda tidak berada pada
>>>>> Sheet "rekap detail".
>>>>>
>>>>> Jika anda mau menjalankan macro tsb dari Sheet
>>>>> "rekap" (setelah macronya dicopas di VBE Sheet)
>>>>> maka perlu ditambahkan instruksi warna merah,
>>>>> artinya Sheet "rekap detail" harus diaktifkan dulu.
>>>>>
>>>>> Salam,
>>>>> HK
>>>>>
>>>>>
>>>>> ----------------------------------------------------------
>>>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>>>> <mailto:abiel_1108@yahoo.com>
>>>>> *To:* belajar-excel@yahoogroups.com
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> *Sent:* Friday, 4 October 2013, 14:54
>>>>> *Subject:* Bls: Bls: [belajar-excel] Need Help
>>>>> melakukan copy paste (breakdown) sheet to sheet [1
>>>>> Attachment]
>>>>>
>>>>> Dear bro Hendrik,
>>>>>
>>>>> sekali lagi mohon bantuannya ya bro, mohon
>>>>> dimaklumi ye bro... namanya newbe and juga pengen
>>>>> tau bisa gimana caranya.
>>>>>
>>>>> kalau itu bisa terealisasi efisiensi waktunya
>>>>> lumayan bro, kan bisa buat ngerjain yang lain.. hehehe
>>>>>
>>>>> terlampir format data yang biasa digunakan.
>>>>>
>>>>>
>>>>>
>>>>> many thanks
>>>>> Ahmad H
>>>>>
>>>>>
>>>>>
>>>>> ----------------------------------------------------------
>>>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>>>>> <mailto:hendrikkarnadi@yahoo.com>
>>>>> *Kepada:* "belajar-excel@yahoogroups.com"
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> <belajar-excel@yahoogroups.com>
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> *Dikirim:* Jumat, 4 Oktober 2013 14:33
>>>>> *Judul:* Re: Bls: [belajar-excel] Need Help
>>>>> melakukan copy paste (breakdown) sheet to sheet
>>>>>
>>>>> Saya sdh tes dan filenya masih disimpan.
>>>>>
>>>>> Coba kirim file yang ada "run time errornya"
>>>>> karena dengan mengetahui/memperbaiki kesalahan
>>>>> tersebut kita dapat semakin memahami dan menikmati
>>>>> macro.
>>>>>
>>>>> JIka anda mau email satu persatu (balasan email
>>>>> anda kepada Miss Jan) kenapa ga langung disave
>>>>> sebagai workbook (pada Dir yang sama) per nama PT ?
>>>>>
>>>>> Salam,
>>>>> HK
>>>>>
>>>>> ----------------------------------------------------------
>>>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>>>> <mailto:abiel_1108@yahoo.com>
>>>>> *To:* belajar-excel@yahoogroups.com
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> *Sent:* Friday, 4 October 2013, 14:02
>>>>> *Subject:* Bls: [belajar-excel] Need Help
>>>>> melakukan copy paste (breakdown) sheet to sheet
>>>>>
>>>>> Dear Bro Hendrik,
>>>>>
>>>>> kok nggak bisa ya.. "run time error"
>>>>>
>>>>> maaf newbe nih... hihihihiihi
>>>>>
>>>>> mohon bantuannya lagi ya bro...
>>>>>
>>>>>
>>>>> many thanks,
>>>>> cheers
>>>>> Ahmad H
>>>>>
>>>>>
>>>>>
>>>>> ----------------------------------------------------------
>>>>> *Dari:* hendrik karnadi <hendrikkarnadi@yahoo.com>
>>>>> <mailto:hendrikkarnadi@yahoo.com>
>>>>> *Kepada:* "belajar-excel@yahoogroups.com"
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> <belajar-excel@yahoogroups.com>
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> *Dikirim:* Jumat, 4 Oktober 2013 12:36
>>>>> *Judul:* Re: [belajar-excel] Need Help melakukan
>>>>> copy paste (breakdown) sheet to sheet
>>>>>
>>>>> Pak De, boleh pinjam codenya ya ?
>>>>> Coba copas macro Pak De Premor di bawah ini pada
>>>>> Sheet VBA Module1 (diambil dari kasus filtering
>>>>> sebelumnya),
>>>>>
>>>>> Sub Masukin()
>>>>> Dim SrcData As Range, Rng As Range
>>>>> Dim cKode As New Collection
>>>>> Dim LRow As Long
>>>>>
>>>>> Application.ScreenUpdating = False
>>>>> Set SrcData = Sheets("rekap
>>>>> detail").Range("E2", Range("E2").End(xlDown))
>>>>> On Error Resume Next
>>>>> For Each Rng In SrcData
>>>>> cKode.Add Trim(Rng), CStr(Rng)
>>>>> Next
>>>>> For LRow = 1 To cKode.Count
>>>>> Set Rng = SrcData.CurrentRegion.Offset(1,
>>>>> 0).Resize(SrcData.Rows.Count, 6)
>>>>> SrcData.CurrentRegion.AutoFilter Field:=5,
>>>>> Criteria1:=cKode.Item(LRow)
>>>>> Rng.SpecialCells(xlCellTypeVisible).Copy
>>>>> Sheets(cKode.Item(LRow)).Range("A2")
>>>>> SrcData.CurrentRegion.AutoFilter
>>>>> Next
>>>>> Application.ScreenUpdating = True
>>>>> End Sub
>>>>>
>>>>> Warna merah adalah bagian yang disesuaikan.
>>>>>
>>>>> Salam,
>>>>> HK
>>>>>
>>>>>
>>>>> ----------------------------------------------------------
>>>>> *From:* Ahmad Habibillah <abiel_1108@yahoo.com>
>>>>> <mailto:abiel_1108@yahoo.com>
>>>>> *To:* belajar-excel@yahoogroups.com
>>>>> <mailto:belajar-excel@yahoogroups.com>
>>>>> *Sent:* Friday, 4 October 2013, 10:57
>>>>> *Subject:* [belajar-excel] Need Help melakukan
>>>>> copy paste (breakdown) sheet to sheet [1 Attachment]
>>>>>
>>>>> Selamat Pagi,
>>>>>
>>>>> mudah-mudah an semua anggota di belajar-excel ini
>>>>> selalu mendapatkan keberkahan dalam hidup. amin
>>>>>
>>>>> dalam hal ini saya mau minta mohon bantuannya
>>>>> untuk permasalahan yang saya alami,
>>>>>
>>>>> dikarenakan olah data ini dilakukan 2 hari sekali
>>>>> maka akan sangat membantu jika dapat di lakukan
>>>>> otomasi by vb or macro.
>>>>>
>>>>> dalam 1 file excel terdapat sheet file detail dan
>>>>> beberapa sheet breakdown nya.
>>>>>
>>>>> berikut saya lampirkan file yang dimaksud.
>>>>>
>>>>> atas perhatian dan bantuannya terima kasih
>>>>>
>>>>> cheers,
>>>>> Ahmad H
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>
>

Fri Oct 4, 2013 11:19 am (PDT) . Posted by:

"Shenly" shenly_excelmania

Assalamualikum...
mohon bantuannya kembali teman2, 
saya sudah membuat coding VBA dari copy paste sebuah tabel, tapi hasilnya tidak sesuai yang saya inginkan, 
harap bantuannya dari teman2 sekalin...
untuk lebih jelas sya sudah lapirkan filenya

terima kasih
 
Salam
Shenly ^^*

Fri Oct 4, 2013 11:37 am (PDT) . Posted by:

"Mr. Kid" nmkid.family@ymail.com

Hai Shenly,

Coba isi prosedurnya diberi script berikut :
Dim rngData As Range, lRows As Long 'variabel range data beserta
jumlah barisnya
Dim rngTarget As Range 'variabel range posisi paste di
kolom A

Set rngData = Range("f1").CurrentRegion.Offset(1).Resize(, 1) 'record
data input kolom A + 1 baris kosong terbawah
lRows = rngData.Rows.Count - 1 'jumlah
record

Set rngTarget = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) 'range
posisi paste di kolom A
rngData.Resize(lRows, 1).Copy 'copy
input kolom A
rngTarget.PasteSpecial xlPasteValues 'paste
values di posisi target kolom A
rngData.Offset(0, 1).Resize(lRows, 2).Copy 'copy
input yang 2 kolom data setelah lompat 1 kolom ke kanan
rngTarget.Offset(0, 2).PasteSpecial xlPasteValues 'paste
values di posisi target kolom A lompat 2 kolom ke kanan

Wassalam,
Kid.

2013/10/5 Shenly <shenly_excelmania@yahoo.co.id>

> **
>
>
> Assalamualikum...
> mohon bantuannya kembali teman2,
> saya sudah membuat coding VBA dari copy paste sebuah tabel, tapi hasilnya
> tidak sesuai yang saya inginkan,
> harap bantuannya dari teman2 sekalin...
> untuk lebih jelas sya sudah lapirkan filenya
>
> terima kasih
>
> Salam
> Shenly ^^*
>
>
>

Sat Oct 5, 2013 12:33 am (PDT) . Posted by:

"prazt math" praztmath

Pk De saya jadi tertarik pada tulisan yang saya kutip sbb: Selain enkripsi
2 arah yang bisa diketaui nilai awalnya, ada juga enkripsi 1 arah, yang
mustahil untuk diketahui nilai awalnya karena sudah diacak2, dibolak-balik,
diaduk-aduk, diobok-obok dst... sehingga menghasilkan sebuah deret huruf
dan angka yang tak bermakna dimata manusia :D Contoh Hasil enkripsi searah
kata "Belajar-Excel" menggunakan MD5 : d1dbd01073ad229fcde3ac345b94c36d.
Pertanyaan saya apakah berkenan jika saya minta cintoh dari pak De password
excel misalnya sheet-sheetnya yang menggunakan enkripsi satu arah pk De?
Dan alur ceritanya supaya saya bisa mempelajari
Pada 2 Okt 2013 06:45, "De Premor" <de@premor.net> menulis:

> **
>
>
> Kalau untuk alternatif proteksi sepertinya tidak, karena tetap sama aja
> hasil dari encryp tetap berupa text, tetapi kalau untuk menyembunyikan
> password mungkin bisa agak sedikit menyulitkan pembacaannya, karena musti
> di convert kesana kemari dulu :D
>
> Dalam fungsi EncDec tersebut dibuat sederhana saja sesuai dengan keperluan
> yang ada (menyembunyikan tanggal yang notabene berupa deretan angka), dan
> harus bisa diambil lagi nilainya menjadi tanggal semula
> yaitu cuma di xor dengan bilangan tertentu kemudian di xor lagi dengan
> bilangan lainnya, kemudian diubah ke Hex, dan membalik prosesnya untuk
> mengetahui nilai sebenarnya.
> Enkripsi model seperti (bolak balik aka 2 arah ) ini tidak tertalu aman,
> karena dapat dengan mudah dikembalikan ke nilai awal, tapi karena
> keperluannya mengharuskan seperti itu ya mau gimana lagi :D
>
> Enkripsi 2 arah yang sudah umum digunakan di jagat coding contohnya
> BASE64, BLOWFISH, ROTATE13 dll
>
> Selain enkripsi 2 arah yang bisa diketaui nilai awalnya, ada juga enkripsi
> 1 arah, yang mustahil untuk diketahui nilai awalnya karena sudah diacak2,
> dibolak-balik, diaduk-aduk, diobok-obok dst... sehingga menghasilkan sebuah
> deret huruf dan angka yang tak bermakna dimata manusia :D
> Contoh Hasil enkripsi searah kata "Belajar-Excel" menggunakan MD5 :
> d1dbd01073ad229fcde3ac345b94c36d
>
> Didalam dunia perenkripsian ada sebuah istilah yang sama "Salting" ,
> dimana hasil dari sebuah enkripsi dienkripsi lagi menggunakan kata tertentu
> untuk menambah keamanan
>
> Sementara ini dulu :D
>
> On 01-10-2013 9:54, hendrik karnadi wrote:
>
>
> Pak De Premor,
>
> Dalam jawaban anda atas "Password Harian", ada suatu fungsi yang
> menarik, yaitu,
>
> Function EncDec(ByVal Anu, Optional Enc As Boolean = True)
> On Error Resume Next
> With Application.WorksheetFunction
> If Enc = True Then
> Anu = Anu Xor 53135 Xor 24642
> EncDec = .Dec2Hex(Anu)
> Else
> Anu = .Hex2Dec(Anu)
> EncDec = Anu Xor 24642 Xor 53135
> End If
> End With
> End Function
>
> Mohon dapat dijelaskan, apakah fungsi Enc ini bisa dipakai sebagai salah
> satu alternatif proteksi file yang lebih sulit dibongkar dan bagaimana cara
> membuat/pemakaiannya.
>
> Terima kasih.
>
> Salam,
> HK
>
>
>
>
>
>
>

Sat Oct 5, 2013 12:53 am (PDT) . Posted by:

"De Premor" de.premor

Coba cari dulu digoogle dengan keyword "md5 algorithm" atau jalan2 ke wiki

http://en.m.wikipedia.org/wiki/MD5

Sent from blekberih 
-----Original Message-----
From: prazt math <praztmath@gmail.com>
Sender: belajar-excel@yahoogroups.com
Date: Sat, 5 Oct 2013 14:33:22
To: group excel<belajar-excel@yahoogroups.com>
Reply-To: belajar-excel@yahoogroups.com
Subject: Re: [belajar-excel] Encryption

Pk De saya jadi tertarik pada tulisan yang saya kutip sbb: Selain enkripsi
2 arah yang bisa diketaui nilai awalnya, ada juga enkripsi 1 arah, yang
mustahil untuk diketahui nilai awalnya karena sudah diacak2, dibolak-balik,
diaduk-aduk, diobok-obok dst... sehingga menghasilkan sebuah deret huruf
dan angka yang tak bermakna dimata manusia :D Contoh Hasil enkripsi searah
kata "Belajar-Excel" menggunakan MD5 : d1dbd01073ad229fcde3ac345b94c36d.
Pertanyaan saya apakah berkenan jika saya minta cintoh dari pak De password
excel misalnya sheet-sheetnya yang menggunakan enkripsi satu arah pk De?
Dan alur ceritanya supaya saya bisa mempelajari
Pada 2 Okt 2013 06:45, "De Premor" <de@premor.net> menulis:

> **
>
>
> Kalau untuk alternatif proteksi sepertinya tidak, karena tetap sama aja
> hasil dari encryp tetap berupa text, tetapi kalau untuk menyembunyikan
> password mungkin bisa agak sedikit menyulitkan pembacaannya, karena musti
> di convert kesana kemari dulu :D
>
> Dalam fungsi EncDec tersebut dibuat sederhana saja sesuai dengan keperluan
> yang ada (menyembunyikan tanggal yang notabene berupa deretan angka), dan
> harus bisa diambil lagi nilainya menjadi tanggal semula
> yaitu cuma di xor dengan bilangan tertentu kemudian di xor lagi dengan
> bilangan lainnya, kemudian diubah ke Hex, dan membalik prosesnya untuk
> mengetahui nilai sebenarnya.
> Enkripsi model seperti (bolak balik aka 2 arah ) ini tidak tertalu aman,
> karena dapat dengan mudah dikembalikan ke nilai awal, tapi karena
> keperluannya mengharuskan seperti itu ya mau gimana lagi :D
>
> Enkripsi 2 arah yang sudah umum digunakan di jagat coding contohnya
> BASE64, BLOWFISH, ROTATE13 dll
>
> Selain enkripsi 2 arah yang bisa diketaui nilai awalnya, ada juga enkripsi
> 1 arah, yang mustahil untuk diketahui nilai awalnya karena sudah diacak2,
> dibolak-balik, diaduk-aduk, diobok-obok dst... sehingga menghasilkan sebuah
> deret huruf dan angka yang tak bermakna dimata manusia :D
> Contoh Hasil enkripsi searah kata "Belajar-Excel" menggunakan MD5 :
> d1dbd01073ad229fcde3ac345b94c36d
>
> Didalam dunia perenkripsian ada sebuah istilah yang sama "Salting" ,
> dimana hasil dari sebuah enkripsi dienkripsi lagi menggunakan kata tertentu
> untuk menambah keamanan
>
> Sementara ini dulu :D
>
> On 01-10-2013 9:54, hendrik karnadi wrote:
>
>
> Pak De Premor,
>
> Dalam jawaban anda atas "Password Harian", ada suatu fungsi yang
> menarik, yaitu,
>
> Function EncDec(ByVal Anu, Optional Enc As Boolean = True)
> On Error Resume Next
> With Application.WorksheetFunction
> If Enc = True Then
> Anu = Anu Xor 53135 Xor 24642
> EncDec = .Dec2Hex(Anu)
> Else
> Anu = .Hex2Dec(Anu)
> EncDec = Anu Xor 24642 Xor 53135
> End If
> End With
> End Function
>
> Mohon dapat dijelaskan, apakah fungsi Enc ini bisa dipakai sebagai salah
> satu alternatif proteksi file yang lebih sulit dibongkar dan bagaimana cara
> membuat/pemakaiannya.
>
> Terima kasih.
>
> Salam,
> HK
>
>
>
>
>
>
>

GROUP FOOTER MESSAGE
=====================================================================
Untuk memudahkan tim penyusun materi Belajar Excel yang lebih sesuai kebutuhan member, silakan ungkapkan permasalahan yang kerap ditemui dalam menggunakan Excel sehari-hari atau hal-hal yang ingin dipelajari dalam jangka dekat ini. Mohon diprioritaskan dari yang sering ditemui sampai yang ingin dipelajari.
Isi sesuai kelompoknya (fitur-fitur, formula-formula tertentu yang masih membingungkan, otomasi atau pemrograman dalam Excel [Macro - VBA], hal lainnya yang membuat Anda kesulitan dalam mempelajari Excel).
Boleh mengisi berulang kali untuk menambah uneg-uneg yang ingin diungkapkan.
Link untuk menuangkan seluruh uneg-uneg tersebut ada di :
http://tech.groups.yahoo.com/group/belajar-excel/database?method=addRecord&tbl=3
=====================================================================
Langkah kecil Anda dalam mengisi database bisa menjadi langkah pertama yang bermanfaat besar untuk kita semua.
=====================================================================

---------------------------------------------------------------------
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
---------------------------------------------------------------------
Diposting oleh EXCEL FEED LEARNING di 00.53

Tidak ada komentar:

Posting Komentar

Langganan: Posting Komentar (Atom)