Cara Membuat File Excel Masing-masing Berdasarkan Daftar Nama di Suatu Kolom dengan Macro VBA
Kali ini kami akan berbagi tip bagaimana cara membuat file Excel otomatis menurut daftar nama-nama unik yang tersimpan di dalam suatu kolom tertentu.
Melalui contoh kode macro yang dapat Anda susun di bawah ini, Anda meminta Excel untuk menyalin baris-baris data tersendiri dari setiap nama yang berbeda atau unik, kemudian menyimpan salinan tersebut di setiap file workbooknya sendiri.
Gambar di atas merupakan contoh tabel data sederhana yang dapat Anda buat untuk mempraktikkan tutorial ini dan pastikan Anda menyimpan file tersebut dalam suatu folder dengan jenis file Excel Macro-Enable Workbook (.xlsm).
Adapun workbook diberi nama menurut nama-nama toko dalam kolom A ditambah dengan tanggal dan waktu kode macro dijalankan.
File-file yang dihasilkan akan tersimpan dalam alamat folder yang sama dimana data aslinya berada.
Silakan Anda ikuti langkah demi langkah berikut untuk menyusun kode macro:
1. Buka file dengan ekstensi .xlsm berisi tabel data seperti pada gambar yang telah Anda buat.
2. Buka VBE dengan cara menekan tombol Alt+F11.
3. Buat module melalui menu Insert > Module.
4. Ketik kode di bawah ini dengan judul macro misalnya BeriNamaFileMasing2 lalu tekan Enter:
Sub BeriNamaFileMasing2()
5. Tepat dibawah garis kode Sub matikan fitur screen updating:
Application.ScreenUpdating = False
6. Tetapkan variabel berjenis data Long untuk mengidentifikasi dan menghitung setiap baris dari kepingan data yang unik dan berbeda dalam kolom A, contohnya A untuk baris data unik dan B untuk hitungan jumlah data unik.
Dim A As Long, B As Long
7. Tetapkan variabel berjenis data String untuk setiap nama unik dan nama workbooknya, contohnya C untuk nama unik dan D untuk nama workbook uniknya:
Dim C As String, D As String
8. Tetapkan variabel contohnya E sebagai bilangan baris terakhir tabel data, F untuk kolom yang tersedia berikutnya satu kolom dihapus dari kolom paling kanan dari tabel data, G untuk barisan sel yang ditempati oleh tabel data:
Dim E As Long, F As Long, G As Range
9. Tetapkan variabel contohnya H sebagai alamat penerima file workbook baru, dan I untuk nama sheet dimana tabel data berada:
Dim H As String, I As String
10. Tetapkan variabel H sebagai alamat folder yang sama seperti file yang sedang dibuka untuk menerima file workbook barunya:
H = ThisWorkbook.Path & "\"
11. Mulai dari nama sheet yang menyimpan daftar aslinya:
I = ActiveSheet.Name
12. Temukan baris sel terakhir dari tabel data:
E = Cells(Rows.Count, 1).End(xlUp).Row
13. Temukan kolom yang mana dua kolom dihapus dari kolom paling kanan dalam daftar:
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column + 2
14. Barisan sel (yang mana kolom A dalam daftar) akan disaring untuk setiap namanya yang unik dan tersendiri.
ThisWorkbook.Worksheets(I).Range("A1:A" & E)
15. Buat daftar nama yang unik dengan fitur AdvancedFilter:
CopyToRange:=Cells(1, F), Unique:=True
16. Hitung nama yang unik kecuali sel judul. Di titik inilah Anda memberitahukan pengguna melalui kotak pesan untuk mengakhiri macro berapa banyak nama unik yang ditemukan dengan kata lain berapa banyak file workbook yang dibuat:
B = WorksheetFunction.CountA(Columns(F)) - 1
17. Gunakan susunan loop For...Next kepada setiap nama-nama unik, saring-saring, lalu simpan data pada workbook baru, dengan tambahan tanggal dan waktu:
For A = 2 To Cells(Rows.Count, F).End(xlUp).Row
18. Buat workbook untuk menyimpan nama unik selanjutnya:
Workbooks.Add 1
19. Masukkan nama unik selanjutnya ke dalam variabel C. Untuk membuka seluruh baris dalam sheet matikan terlebih dahulu mode AutoFilter:
.AutoFilterMode = False
C = .Cells(A, F).Value
End With
20. Tetapkan nama workbook dengan nama unik yang lengkap, termasuk jenis ekstensi file-nya. Akhiran tanggal dan waktu mungkin nantinya dapat membantu penelusuran data serta menghindari tumpang tindih nama file workbook yang sudah tersimpan dalam komputer:
Format(VBA.Now, "DDMMYYYY_HHMMSS") & ".xlsx"
21. Saring daftar untuk nama unik selanjutnya:
G.AutoFilter Field:=1, Criteria1:=C
22. Salin baris yang nampak setelah disaring, lalu salin dan simpan ke dalam file workbook baru:
G.SpecialCells(xlCellTypeVisible).EntireRow.Copy Range("A1")
23. Ingat bahwa workbook yang sedang dibuka saat ini adalah workbook baru yang Anda buat, maka daftar nama unik masih nampak dan tidak diperlukan sehingga harus dihilangkan dari kolom:
Columns(F).Clear
24. Agar lebih mudah terbaca kolom disesuaikan dengan lebarnya pada file workbook baru:
Cells.Columns.AutoFit
25. Simpan lalu tutup file workbook baru, sebagai catatan saja bahwa dikarenakan file baru yang disimpan adalah berjenis ekstensi .xlsx maka formatnya 51 sedangkan jika ekstensinya .xlsm maka formatnya harus 52:
Filename:=H & _
D, FileFormat:=51
26. Tutup file workbook yang baru:
ActiveWorkbook.Close
27. Lanjutkan proses loop ke seluruh nama unik:
Next A
28. Aktifkan kembali workbook dan worksheet sumber data:
Worksheets(I).Activate
29. Matikan mode AutoFilter:
ActiveSheet.AutoFilterMode = False
30. Hapus daftar unik:
Columns(F).Clear
31. Lepaskan variabel objek dari memori sistem:
Set G = Nothing
32. Hidupkan kembali mode ScreenUpdating:
Application.ScreenUpdating = True
33. Beritahukan kepada pengguna bahwa proses telah berhasil dituntaskan:
"Tercatat ada " & B & " nama yang unik dan berbeda." _
& vbCrLf & _
"Masing-masing data telah digabungkan ke dalam" & _
vbCrLf & _
"file-nya tersendiri, semua file disimpan di alamat" & vbCrLf & _
H & ".", vbInformation, "Selesai!"
34. Berikut ini kode lengkapnya;
Application.ScreenUpdating = False
Dim A As Long, B As Long
Dim C As String, D As String
Dim E As Long, F As Long, G As Range
Dim H As String, I As String
H = ThisWorkbook.Path & "\"
I = ActiveSheet.Name
E = Cells(Rows.Count, 1).End(xlUp).Row
F = Cells.Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column + 2
Set G = _
ThisWorkbook.Worksheets(I).Range("A1:A" & E)
G.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(1, F), Unique:=True
B = WorksheetFunction.CountA(Columns(F)) - 1
For A = 2 To Cells(Rows.Count, F).End(xlUp).Row
Workbooks.Add 1
With ThisWorkbook.Worksheets(I)
.AutoFilterMode = False
C = .Cells(A, F).Value
End With
D = C & "_" & _
Format(VBA.Now, "DDMMYYYY_HHMMSS") & ".xlsx"
G.AutoFilter Field:=1, Criteria1:=C
G.SpecialCells(xlCellTypeVisible).EntireRow.Copy Range("A1")
Columns(F).Clear
Cells.Columns.AutoFit
ActiveWorkbook.SaveAs _
Filename:=H & _
D, FileFormat:=51
ActiveWorkbook.Close
Next A
ThisWorkbook.Activate
Worksheets(I).Activate
ActiveSheet.AutoFilterMode = False
Columns(F).Clear
Set G = Nothing
Application.ScreenUpdating = True
MsgBox _
"Tercatat ada " & B & " nama yang unik dan berbeda." _
& vbCrLf & _
"Masing-masing data telah digabungkan ke dalam" & _
vbCrLf & _
"file-nya tersendiri, semua file disimpan di alamat" & vbCrLf & _
H & ".", vbInformation, "Selesai!"
End Sub
35. Tekan Alt+Q untuk kembali ke tampilan worksheet.
36. Uji coba macro yang Anda buat dengan menekan Alt+F8.
37. Pada kotak dialog Macro pilih BeriNamaFileMasing2 dan klik tombol Run.
Itulah pembahasan tentang bagaimana cara membuat file workbook Excel secara otomatis menurut daftar nama-nama unik yang tersimpan di dalam suatu kolom tertentu.
Selamat mempraktikkan dan semoga postingan ini bermanfaat.