Option Explicit
Sub AutoCopyFile()
Dim BaseBook, MyBook As Workbook ''BaseBook là file tổng hợp, MyBook la biến chỉ định từng file report con
Dim SourceRange, DestRange As Range ''SourceRange là vùng cần copy trong file con, DestRange la vùng trên file tổng hợp để copy vào
Dim Zn, Zj As Long
Trong đó, Zn là số lượng file cần copy, Zi la biến chạy tham chiếu đến số lượng sheet trong từng file
'---------------------------------
Dim MyPath, SaveDriveDir As String
Dim FName As Variant
'---------------------------------
SaveDriveDir = CurDir
MyPath = "D:\Report\" 'Khai báo đường dẫn cố định chứa các file cần copy, nếu sửa thì sửa chỗ này
ChDrive MyPath
ChDir MyPath
'============================================================================
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'============================================================================
'Lựa chọn các file để copy, có thể chọn nhiều file cùng lúc:
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", MultiSelect:=True)
If IsArray(FName) Then
Set BaseBook = Workbooks("ReportSum.xls")
'============================================================================
'Bắt đầu duyệt qua từng file để copy:
For Zn = LBound(FName) To UBound(FName)
Set MyBook = Workbooks.Open(FName(Zn))
'Bắt đầu chon từng sheet trong file để copy:
For Zj = 1 To MyBook.Worksheets.Count
Set SourceRange = MyBook.Worksheets(Zj).UsedRange 'Chỉ quét chọn các ô nào có dữ liệu
BaseBook.Activate
'----------------------------------------------------------------
'Tạo sheet mới trước khi copy:
BaseBook.Worksheets.Add
'----------------------------------------------------------------
'Đặt tên cho sheet mới:
ActiveSheet.Name = MyBook.Name & "_" & MyBook.Worksheets(Zj).Name
'----------------------------------------------------------------
'Xác định vùng để Copy và Paste:
Set DestRange = BaseBook.ActiveSheet.Cells(1, 1)
MyBook.Worksheets(Zj).Cells.Copy
BaseBook.ActiveSheet.Paste
Next Zj
MyBook.Close False
Next Zn
End If
'========================================================================
'Trả về mặc định trước khi mở file:
ChDrive SaveDriveDir
ChDir SaveDriveDir
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
