Dear Be-Excel,
Sehubungan dengan pertanyaan dari seorang member dari negara antah berantah
mengenai hal tersebut diatas yang mirip dengan masalah yang pernah saya
sampaikan sebelumnya....saya mencoba merevisi file sebelumnya (Master) sehingga
menjadi lebih mudah.
Pertanyaannya adalah sebagai berikut (terjemahan bebas):Saya mempunyai beberapa
file dalam dua directory tapi mempunyai nama2 yang sama, mis- Dir 1, file
1,2,3- Dir 2, file 1,2,3Saya ingin mencopy isi file2 tersebut.
Pertanyaan tersebut saya coba kembangkan menjadi:"Saya ingin mengcopy isi
beberapa file yang berada dalam beberapa directory dan masing2 file mempunyai
beberapa sheet yang tidak sama.
Setelah Macronya dibuat, hanya perlu 3 langkah untuk melaksanakannya :- Buka
blank Workbook yang mempunyai peling sedikit 2 Sheet- Tulis nama2 folder atau
sub folder pada Sheet2 Range A1, dstnya (dalam contoh di atas Range A1 diisi
dengan D1 dan Range A2 diisi dengan D2)- Copas dan jalankan macro di bawah ini
pada Sheet1 (macro harus aktif),
Option Explicit
Sub ReadAndMergeData()
' ERROR CATCHING
On Error GoTo ErrHandler
' FREEZE SCREEN
Application.ScreenUpdating = False
' CLEAR ALL DATA
Cells.Clear
' OUR FILE SYSTEM OBJECTS AND VARIABLES
Dim objFs As Object
Dim objFolder As Object
Dim file As Object
Dim dst As Workbook
Dim src As Workbook
Dim wks As Worksheet
Dim i As Integer
Dim mynextrow As Integer
' THE DESTINATION WORKBOOK AND STARTED ROW
Set dst = ThisWorkbook
mynextrow = 1
' SET FILESYSTEMOBJECT
Set objFs = CreateObject("Scripting.FileSystemObject")
' LOOP THROUGH ALL THE PATHS OF THE SOURCE FOLDER
For i = 1 To WorksheetFunction.CountA(Sheet2.Columns("A:A"))
Set objFolder = objFs.GetFolder(Sheet2.Range("A" & i).Value)
' LOOP THROUGH ALL THE WORKBOOKS AND WORKSHEETS IN THE SOURCE FOLDER
For Each file In objFolder.Files
' THE SOURCE WORKBOOK
Set src = Workbooks.Open(file.Path, True, True)
For Each wks In src.Worksheets
dst.Sheets("sheet1").Cells(mynextrow, 1).Value = file & " (" &
wks.Name & ")"
dst.Sheets("sheet1").Cells(mynextrow, 1).Font.Bold = True
wks.UsedRange.Copy
dst.Sheets("sheet1").Cells(mynextrow + 1, 1).PasteSpecial
Paste:=xlPasteValues
mynextrow = dst.Sheets("sheet1").UsedRange.Rows.Count + 2
Next wks
' CLOSE SOURCE WORKBOOK AND SET TO NOTHING
src.Close False
Set src = Nothing
Next file
Next i
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Semoga bermanfaat.
Salam,HK
