COPY MULTIFILE EXCEL DI SATU FOLDER 12

Posting ini aku buat, karena banyaknya request mengenai copy multi file excel.
Sebelumnya aku pernah membuat postingan mengenai copy data multifile excel yang bersifat dasar.

Sekalian mo kasih informasi kalau tulisan di blog ini, aku buat bukan karena sok tahu atau sok ngajarin, tetapi sebagai catatan dan pembelajaran bagi aku secara pribadi, dan syukur ada gunanya bagi orang lain, tetapi karena blog ini bisa dilihat siapa saja, jadi yach mohon maaf apabila ada kesalahan.

Langsung saja ke penjelasan perihal postingan ini, dimana prosesnya adalah melakukan copy data sheet 1, dari semua file excel di folder yang telah ditentukan, dan melakukan paste value pada sheet baru.

Sedangkan untuk kodenya adalah :

Sub copy_multifile_difolder()
Dim foldr As String
Dim nwb As Workbook
Dim lwb As Workbook
Dim nws As Worksheet
Dim ws As Worksheet
Dim fileku As String
Dim rngku As Range
Dim rnum As Long

foldr = ThisWorkbook.Path & "\fileku\" 'kondisi foldr sebagai alamat folder fileku
Set nwb = Workbooks.Add(1) 'tambah sheet
Set nws = nwb.ActiveSheet 'sheet baru menjadi aktif
Set ws = Sheets(1) 'setting ws sebagai sheet 1

'kondisi jika dibelakang folder tidak ada tanda "\"
If Right(foldr, 1) <> "\" Then
foldr = foldr & "\"
End If

'kondisi jika tidak ada file di folder fileku
fileku = Dir(foldr & "*.xl*")
If fileku = "" Then
MsgBox "tidak ada file excel"
Exit Sub
End If

Do Until fileku = ""
If foldr <> ThisWorkbook.Path Or fileku <> ThisWorkbook.Name Then
Set lwb = Workbooks.Open(Filename:=foldr & fileku) 
'kondisi untuk setiap sheet 1
For Each ws In lwb.Worksheets
'setting range yang akan di copy
Set rngku = ws.Range("A2", ws.Cells(ws.UsedRange.Row + ws.UsedRange.Rows.Count, ws.UsedRange.Column + ws.UsedRange.Columns.Count))
'membuat judul
If rnum = 0 Then
nws.Range("A1", nws.Cells(1, rngku.Columns.Count)).Value = ws.Range("A1", ws.Cells(1, rngku.Columns.Count)).Value
rnum = 1
End If
'copy data dari file sumber ke sheet baru
rngku.Copy
nws.Range("A" & rnum + 1).Resize(rngku.Rows.Count, rngku.Columns.Count).PasteSpecial xlPasteValues
rnum = rnum + rngku.Rows.Count - 1
Next
lwb.Close False
End If
fileku = Dir() 'setting nama file menjadi variable
Loop

nwb.Sheets(1).Select
Application.EnableEvents = True
Application.ScreenUpdating = True

'membersihkan memory
Set nwb = Nothing
Set nws = Nothing
Set ws = Nothing
Set lwb = Nothing
Set rngku = Nothing
End Sub

Demikianlah sehingga postingan ini berakhir, mohon informasinya apabila ada kesalahan.
Dan sekali lagi file bisa langsung di Download disini.