VBA gộp nhiều file .xls thành 1 sheet

[thanhhong.hr]

Em có rất nhiều file .xls muốn gộp thành 1 sheet, có bạn chỉ giúp VBA này nhưng em làm đang bị lỗi, em đang rất cần, mong mng sửa giúp em với ạ, Em cảm ơn nhiều nhiều ạ!!!!

Option Explicit

Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  Application.ScreenUpdating = False
  Sheets("Tong_Hop").Range("A2:F10000").ClearContents
  vFile = Application.GetOpenFilename("Excel File, .xls; .xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A2:F10000"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Done!"
  End If
End Sub

 

[Hoàng Tuấn 868]

Em có rất nhiều file .xls muốn gộp thành 1 sheet, có bạn chỉ giúp VBA này nhưng em làm đang bị lỗi, em đang rất cần, mong mng sửa giúp em với ạ, Em cảm ơn nhiều nhiều ạ!!!!
Option Explicit
Sub Main()
Dim vFile, FileItem, aRes, Target As Range
Dim FileName As String, SheetName As String, RangeAddress As String
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Tong_Hop").Range("A2:F10000").ClearContents
vFile = Application.GetOpenFilename("Excel File, .xls; .xlsx; *.xlsm", , , , True)
If TypeName(vFile) = "Variant()" Then
SheetName = "Sheet1": RangeAddress = "A2:F10000"
For Each FileItem In vFile
FileName = CStr(FileItem)
If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
aRes = GetData(FileName, SheetName, RangeAddress, False, False)
If IsArray(aRes) Then
Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End If
End Sub

Bạn tham khảo tại đây xem sao.

 

[Nhattanktnn]

Em có rất nhiều file .xls muốn gộp thành 1 sheet, có bạn chỉ giúp VBA này nhưng em làm đang bị lỗi, em đang rất cần, mong mng sửa giúp em với ạ, Em cảm ơn nhiều nhiều ạ!!!!
Option Explicit
Sub Main()
Dim vFile, FileItem, aRes, Target As Range
Dim FileName As String, SheetName As String, RangeAddress As String
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Tong_Hop").Range("A2:F10000").ClearContents
vFile = Application.GetOpenFilename("Excel File, .xls; .xlsx; *.xlsm", , , , True)
If TypeName(vFile) = "Variant()" Then
SheetName = "Sheet1": RangeAddress = "A2:F10000"
For Each FileItem In vFile
FileName = CStr(FileItem)
If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
aRes = GetData(FileName, SheetName, RangeAddress, False, False)
If IsArray(aRes) Then
Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End If
End Sub

Bạn đưa function GetData lên mình chạy thử xem, mà có thể là file bạn bị lỗi nên workbook.Open không được
Mình mở nó báo thế này

 

[Quang_Hải]

Em có rất nhiều file .xls muốn gộp thành 1 sheet, có bạn chỉ giúp VBA này nhưng em làm đang bị lỗi, em đang rất cần, mong mng sửa giúp em với ạ, Em cảm ơn nhiều nhiều ạ!!!!
Option Explicit
Sub Main()
Dim vFile, FileItem, aRes, Target As Range
Dim FileName As String, SheetName As String, RangeAddress As String
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Tong_Hop").Range("A2:F10000").ClearContents
vFile = Application.GetOpenFilename("Excel File, .xls; .xlsx; *.xlsm", , , , True)
If TypeName(vFile) = "Variant()" Then
SheetName = "Sheet1": RangeAddress = "A2:F10000"
For Each FileItem In vFile
FileName = CStr(FileItem)
If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
aRes = GetData(FileName, SheetName, RangeAddress, False, False)
If IsArray(aRes) Then
Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End If
End Sub

Viết lại code mới cho bạn. Code bạn đang sử dụng đôi lúc sẽ gặp chút trục trặc. Copy file này để vào thư mục chứa các file cần tổng hợp

 

[Nhattanktnn]

Viết lại code mới cho bạn. Code bạn đang sử dụng đôi lúc sẽ gặp chút trục trặc. Copy file này để vào thư mục chứa các file cần tổng hợp

Bác Hải cho em hỏi chút, nếu dùng phương pháp này (không workbooks.open) mà file muốn tổng hợp không xác định số lượng sheet, tên sheet. Thì muốn lặp qua hết từng sheet của từng file thì làm thế nào?

 

[Quang_Hải]

Bác Hải cho em hỏi chút, nếu dùng phương pháp này (không workbooks.open) mà file muốn tổng hợp không xác định số lượng sheet, tên sheet. Thì muốn lặp qua hết từng sheet của từng file thì làm thế nào?

Mình nghĩ là có thể viết 1 hàm lấy tên sheet của file đang đóng, sau đó thì cứ vòng lặp mà xử lý. Dạo này cũng lười nên không nghiên cứu những dạng code không thông dụng cho công việc văn phòng