Sub Merge tất cả các sheet trong nhiều file vào 1 sheet của 1 file

Đây là một yêu cầu mà mình đọc được khá nhiều trên những job Freelancer về Excel và bản thân mình cũng trải qua nhiều task có yêu cầu tương tự. Trong qua trình tìm hiểu thì có kha khá sub tham khảo trên Internet không hoạt động, đây là sub thành công và đơn giản nhất mình sưu tầm được.

 Lưu ý:

1. Mở tất cả các file cần gộp khi chạy sub này(không mở những file không cần gộp)

2. File kết quả sẽ được tạo mới.

3. Sau khi có kết quả, cần xóa những dòng tiêu đề vì khi copy, Sub sẽ cop toàn bộ những dòng có data trong file.

(Nguồn :Internet)

Sub MergeMultipleSheetsToNew()

On Error GoTo eh

   Dim wbDestination As Workbook

   Dim wbSource As Workbook

   Dim wsDestination As Worksheet

   Dim wb As Workbook

   Dim sh As Worksheet

   Dim strSheetName As String

   Dim strDestName As String

   Dim iRws As Integer

   Dim iCols As Integer

   Dim totRws As Integer

   Dim strEndRng As String

   Dim rngSource As Range

   Application.ScreenUpdating = False

   Set wbDestination = Workbooks.Add

   strDestName = wbDestination.Name

   For Each wb In Application.Workbooks

      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then

         Set wbSource = wb

         For Each sh In wbSource.Worksheets

            sh.Activate

            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate

            iRws = ActiveCell.Row

            iCols = ActiveCell.Column

            strEndRng = sh.Cells(iRws, iCols).Address

            Set rngSource = sh.Range("A1:" & strEndRng)

           wbDestination.Activate

           Set wsDestination = ActiveSheet

           wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select

           totRws = ActiveCell.Row

           If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then

               MsgBox "There are not enough rows to place the data in the Consolidation worksheet."

               GoTo eh

           End If

           If totRws <> 1 Then totRws = totRws + 1

           rngSource.Copy Destination:=wsDestination.Range("A" & totRws)

      Next sh

   End If

   Next wb

   For Each wb In Application.Workbooks

      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then

         wb.Close False

      End If

   Next wb

   Set wbDestination = Nothing

   Set wbSource = Nothing

   Set wsDestination = Nothing

   Set rngSource = Nothing

   Set wb = Nothing

   Application.ScreenUpdating = False

Exit Sub

eh:

MsgBox Err.Description

End Sub