Re: ]] XL-mania [[ memindahkan banyak worksheet ke workbook yang berbeda2

 

Dua listing code yg telah ditayangkan sebelumnya; hanyalah dimaksudkan sbg

pengantar untuk akhirnya memperlihatkan bahwa prosedur tsb dapat ditulis 

lebih ringkas menjadi seperti ini

Sub Memisah_Workbook()

   ' siti Vi / 19 aug 2010 (versi 3)

   ' menyimpan tiap sheet sbg workbook di folder tertentu

   ' [nama sheet] & [WeekNum] menjadi nama workbook baru

   ' tidak harus aktifkan fungsi WeeNum (dlm AnalysisTool)

   '--------------------------------------------------------------

   Dim i As Integer, W As Worksheet, WeekNo As String

   

   WeekNo = "_Week" & CStr(DatePart("ww", Date, vbUseSystemDayOfWeek, vbUseSystem))

   For Each W In ThisWorkbook.Worksheets

      If Not W.Name = ActiveSheet.Name Then

         ThisWorkbook.Sheets(W.Name).Copy

         ActiveWorkbook.SaveAs _

            Filename:="D:\" & W.Name & "\" & W.Name & WeekNo & ".xls"

         ActiveWorkbook.Close Savechanges:=True

      End If

   Next W

End Sub

Jika anda sudah membaca dua listing sebelumnya, listing terakhir ini tidak perlu lagi 

ada comments penjelasan.

Yang perlu diketahui adalah: 

** makro tidak dibatasi hanya memproses 5 sheet, tetapi SEMUA Sheets yg ada

dlm "ThisWorkbook" kecuali sheet1 (dlm contoh = sheet "mail")

** makro ini belum diberi kemampuan untuk membuat FOLDER BARU jika di D:\ 

belum ada Folder dgn nama Seperti NAMA SHEET pada " ThisWorkbook"   (kecuali

NAMA SHEET dimana Tombol Pemanggil Makro berada. (dlm contoh = sheet "mail")

Jadi untuk sementara anda harus melihat di path D:\ apakah sudah ada folders terrnaksud.

kemudian membuatnya jika belum ada...

Jika diperlukan, perintah seperti itu tidak sulit untuk ditambahkan dlm prosedur di atas.

Oiya, jangan lupa melihat coding untuk si Tombol di module milik Sheet1

2010/8/19 STDEV(i) <setiyowati.devi@gmail.com>

MODIFIKASI dikittt

nama nama workbook tujuan & folders tujuan 

tidak harus di HARD-CODED seperti contoh sebelumnya

Sub MemisahWorkbook()

   ' siti Vi / 19 aug 2010 (versi 2)

   Dim i As Integer, WNames(), sht As Worksheet

   Dim DestPath As String, WeekNo As String

   ReDim WNames(1 To ThisWorkbook.Worksheets.Count - 1)

   For Each sht In ThisWorkbook.Worksheets

      If Not sht.Name = ActiveSheet.Name Then

         i = i + 1: WNames(i) = sht.Name

      End If

   Next sht

   WeekNo = ctvWeekNum(Date)

   For i = 1 To UBound(WNames)

      DestPath = "D:\" & WNames(i) & "\"

      ThisWorkbook.Sheets(WNames(i)).Copy

      ActiveWorkbook.SaveAs _

         Filename:=DestPath & WNames(i) & "_Week" & WeekNo & ".xls", _

         FileFormat:=xlNormal

      ActiveWorkbook.Close Savechanges:=True

   Next i

End Sub

Private Function ctvWeekNum(InputDate As Date)

   ctvWeekNum = DatePart("ww", InputDate, vbUseSystemDayOfWeek, vbUseSystem)

End Function

2010/8/19 moch_yasin_87 <id42_shin@yahoo.co.id>> Dear XL Mania,

> Saya sedang bingung untuk membuat makro nih,
> Tiap hari rabu saya harus membuat laporan dari excel, dimana workbook dari laporan tersebut 

> terdiri dari 5 worksheet (aspira, vitron,...,mito).
> Bagaimana caranya agar kelima worksheet tersebut bisa saya pindahkan ke 5 workbook yang berbeda-beda:
> aspira->wb1
> vitron->wb2
> ........
> mito->wb5
> Kemudian setiap workbook tersebut disave ke folder yang berbeda-beda dengan format:
> namaworksheet_mingguke...
> contohnya:
> wb1->D:\aspira\aspira_week32
> wb2->D:\vitron\vitron_week32
> .......
> wb5->D:\mito\mito_week32
> Mohon bantuannya, sebelumnya, saya ucapkan terima kasih banyak.
> regards,
> Yasin

__._,_.___

Reply to sender | Reply to group | Reply via web post | Start a New Topic

Messages in this topic (3)

Recent Activity:

• New Members 102

Visit Your Group

+-:: XL-mania ::::::::::::::::::::----------------------------------+
| selamat menunaikan ibadah puasa... walau perut lapar, tanya excel |
| jalan terus... malu bertanya telat pulang kantor :D :D :D         |
| http://www.facebook.com/group.php?gid=37671048001&ref=mf          |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message,  melecehkan,  tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan  winzip  jika  perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke  |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/           |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau...  |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html           |
+-------------------------------------------------------------------+
| Message lama ada di :                                             |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id]  |
| http://www.mail-archive.com/xl-mania@yahoogroups.com              |
+-------------------------------------------------------------------+

Switch to: Text-Only, Daily Digest • Unsubscribe • Terms of Use

.

__,_._,___