Memisahkan Sheet di Excel Menjadi File Excel Lain

Malam ini terbesit ide untuk menuliskan tentang sebuah tips dan trik yang saya dapatkan ketika di kantor.

Rekan kerja di kantor saya meminta tolong untuk memisahkan sheet di excel menjadi file excel lain secara terpisah.

Dari sheet-sheet berikut ini:

Dipecah menjadi file-file terpisah seperti ini:

Awalnya saya mau melakukan ini secara manual, namun setelah melakukannya pada beberapa sheet, kok rasanya pekerjaan ini berulang-ulang dan terasa “membosankan”. Dan juga sheet-sheet yang ada ini juga terlalu banyak, kurang lebih ada 20an. Berhubung saya ~~rajin~~ malas (hehehe), maka saya coba riset sedikit di google. “Apakah bisa pekerjaan ini diotomatisasi?” begitu pikir saya dalam hati.

BANG! Setelah saya googling sedikit, maka ketemu caranya. Ada pada halaman berikut ini . Saya lihat tutorial tersebut dan melihat pada bagian berikut:

Export And Save Worksheets As New Workbook With VBA Code

Tanpa ragu, saya mencobanya. BANG! Berhasil ternyata. Ini magic. Hehehe.

Alhasil saya bisa menghemat waktu untuk menyelesaikan pekerjaan tersebut.

Jadi berikut ini scriptnya. Silahkan mencoba. Dan tutorial lengkapnya ada di sini ya: https://www.extendoffice.com/documents/excel/785-excel-save-export-sheet-as-new-workbook.html

Sub SplitWorkbook()
'Updateby20140612
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

Semoga bermanfaat untuk rekan-rekan BMKG yang mengalami hal serupa di atas seperti saya. Dan juga semoga bermanfaat untuk para pembaca blog ini.

Berhubung ini masih di pertengahan Ramadhan. Terus tingkatkan ibadah, ya Guys.

See you.

Bio
Latest Posts

mahisaajy

PMG Ahli Pertama, Bidang Manajemen Database at BMKG

Seorang pemuda luar biasa yang mempunyai hobi menulis, membaca, dan bermusik. Tertarik dengan bidang ilmu komputer untuk memecahkan beberapa persoalan. Co-Founder Triglav ID dan Co-Founder METLIGO. Sejak tahun 2018 bekerja di BMKG di bagian Pusat Database.