Tổng hợp dữ liệu từ nhiều workbook trong cùng một thư mục

[levanduyet]

Chúng ta thường có bài toán như sau:

• Công ty mẹ có nhiều công ty con, mỗi công ty con sẽ gởi về báo cáo hàng ngày với một định dạng nhất định. Bài toán được người dùng đặt ra là tổng hợp các dữ liệu báo cáo trên nhiều workbook này về một workbook khác.
• Dữ liệu được xuất ra từ máy dưới dạng Excel, và để cùng một thư mục. Tôi muốn tổng hợp các dữ liệu này.

Đây là vấn đề mà các thành viên thường đặt ra trên diễn đàn. Chính vì khi tôi thăm các trang blog, forum nước ngoài, thấy họ đã tổng hợp nên tôi đưa vào đây để các bạn tiện tham khảo.

Có bốn ví dụ cơ bản:
1) Merge một vùng từ tất cả các workbook in một thư mục - Merge a range from all workbooks in a folder (below each other)
2) Merge một vùng từ mỗi workbook bạn chọn - Merge a range from every workbook you select (below each other)
3) Merge một vùng từ tất cả các workbook trong một thư mục - Merge a range from all workbooks in a folder (next to each other)
4) Merge một vùng từ tất cả các workbook trong một thư mục với AutoFilter - Merge a range from all workbooks in a folder with AutoFilter

Thông tin và các Tips:

Các ví dụ dưới đây chỉ làm việc cho một thư mục (không áp dụng cho thư mục con)
Chú ý: workbook chứa mã (code) phải được đặt bên ngoài thư mục chứa các workbook cần tổng hợp dữ liệu.

Tip 1: Đối số hữu ích của Workbooks.Open - Useful Workbooks.Open arguments

Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), _
Password:="ron", WriteResPassword:="ron", UpdateLinks:=0)

Nếu workbook của bạn được protected bạn có thể dùng Workbooks.Open với tham số

Password:="ron” and WriteResPassword:="ron"

Đôi khi mở workbook ra, bạn sẽ thấy hiện thông báo hỏi bạn có muốn "update" các link hay không.
Khi mở workbook với tham số UpdateLinks:=0 bạn sẽ tránh được thông báo hởi bạn muốn update hay không.
Nếu muốn mở workbook mà update các link thì bạn dùng UpdateLinks:=3

Bạn có thể tham khảo thông tin thêm tại đây

Tip 2: merge từ tất cả các tập tin với tên bắt đầu, giả sử bắt đầu với từ week

Các bạn có thể dùng:

FilesInPath = Dir(MyPath & "week*.xl*")

Tip 3: Copy các giá trị (values) kể cả formats

Bạn hãy áp dụng ví dụ sau:

With SourceRange
    ' [COLOR="Blue"]destrange là vùng bạn cần đưa dữ liệu vào[/COLOR]
    Set destrange = destrange. _
                    Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = SourceRange.Value

With
' [COLOR="Blue"]SourceRange: vùng bạn cần phải copy dữ liệu[/COLOR]
SourceRange.Copy
With destrange
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End With

Trước khi bạn bật các tính năng ScreenUpdating, Calculation và EnableEvents, bạn cũng thêm hàng sau

Application.Goto BaseWks.Cells(1)

(Về vấn đề này các bạn tham khảo tại đây.)

Xin xem tập tin ví dụ đính kèm.

Nguồn tại đây.

 

[levanduyet]

Các bước thực hiện việc tổng hợp dữ liệu từ các tập tin cùng thư mục có thể tóm tắt như sau:

1. Xác định đường dẫn đến thư mục chứa các tập tin muốn tổng hợp.
2. Lấy danh sách tên các tập tin.
3. Duyệt qua các tập tin này (có thể là *.xls, có thể là *.txt hay *.csv) và đưa dữ liệu ra một workbook mới (hay một workbook nào đó) theo yêu cầu.

Các câu lệnh thường dùng ở đây là:
1) Xác định đường dẫn đến thư mục

  [COLOR="Teal"]  'Đường đến thư mục các tập tin bạn cần tổng hợp.[/COLOR]
    MyPath = "C:\Users\Ron\test"

  [COLOR="Green"]  'Thêm \ vào đường dẫn[/COLOR]
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

Hoặc có thể thay đổi thư mục mặc định nếu muốn dùng cho GetOpenFilename

Private Declare Function SetCurrentDirectoryA Lib _
        "kernel32" (ByVal lpPathName As String) As Long

Public Function [COLOR="Red"]ChDirNet[/COLOR](szPath As String) As Boolean
[COLOR="Teal"]'based on Rob Bovey's code[/COLOR]
    Dim lReturn As Long
    lReturn = SetCurrentDirectoryA(szPath)
    ChDirNet = CBool(lReturn <> 0)
End Function

Sub Test()
Dim TxtFileNames As Variant

  [COLOR="Teal"]  ' Thay đổi thư mục mặc định
    ' Bạn có thể đưa đường dẫn của mình vào đây. Ví dụ[/COLOR] [COLOR="Red"]ChDirNet("D:\MyFolder")[/COLOR]
     ExistFolder = ChDirNet(Application.DefaultFilePath)
    If ExistFolder = False Then
        MsgBox "Lỗi xãy ra khi thay đổi thư mục."
        Exit Sub
    End If
 [COLOR="Teal"]   ' Đưa danh sách tập tin vào biến TxtFileNames [/COLOR]
    TxtFileNames = Application.GetOpenFilename _
    (filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)

End Sub

Sau đó muốn thực hiện tiếp thì phải kiểm tra xem biến TxtFileNames có phải là mảng hay không thì thực hiện tiếp

If IsArray(TxtFileNames) Then

    [COLOR="Teal"]    ' Duyệt qua mảng của tập tin txt [/COLOR]
        For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)
             [COLOR="Green"] ' Thực hiện các thao tác với tập tin
              ' Như lấy dữ liệu,....[/COLOR]

        Next Fnum


End If

2) Đưa danh sách các tập tin vào một biến mảng

 [COLOR="Green"]   ' Nếu không có tập tin Excel trong thư mục này thì thoát thủ tục
    ' Trong những trường hợp khác các bạn có thể thay đổi dạng tập tin mà bạn muốn tổng hợp
    ' tại đoạn mã này[/COLOR]
    FilesInPath = Dir(MyPath & "[COLOR="Red"]*.xl*[/COLOR]")
    If FilesInPath = "" Then
        MsgBox "Không có tập tin nào."
        Exit Sub
    End If

  [COLOR="Green"]  'Điền vào mảng myFiles với danh sách các tập tin theo yêu cầu ở trên[/COLOR]
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

1) Merge một vùng từ tất cả các workbook trong một thư mục - Merge a range from all workbooks in a folder (below each other)

Có một vài chỗ bạn cần phải thay đổi trước khi bạn có thể thực hiện đoạn mã

Thay đổi đường dẫn đến thư mục

MyPath = "C:\Users\Ron\test"

Trong ví dụ này, worksheet đầu tiên của mỗi workbook được dùng (index 1)
Thay đổi worksheet index hay điền điền tên sheet: mybook.Worksheets("YourSheetName")
Và thay vùng A1:C1 tương ứng với vùng của bạn

With mybook.Worksheets(1)
    Set SourceRange = .Range("A1:C1")
End With

Nếu bạn muốn copy tất cả kể từ ô A2 đến ô cuối cùng trên worksheet,
thì bạn thay đoạn mã ở trên bằng đoạn mã sau:

With mybook.Worksheets(1)
    FirstCell = "A2"
    Set SourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
    'Test nếu hàng của ô cuối cùng  >=  hàng của FirstCell
    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
         Set SourceRange = Nothing
    End If
End With

Và thêm vào hàng này ở phần khai báo của macro

Dim FirstCell As String

Bạn đưa ô đầu tiên ở đây, đoạn mã sẽ tìm ô cuối cùng của worksheet cho bạn.

FirstCell = "A2"

Sau đây là đoạn mã chính được sử dụng:

Sub Basic_Example_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

  [COLOR="Green"]  'Đường dẫn đến thư mục chứa các tập tin[/COLOR]
    MyPath = "C:\Users\Ron\test"

 [COLOR="Green"]   'Thêm vào \[/COLOR]
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

  [COLOR="Green"]  'Nếu không có tập tin nào thì thoát[/COLOR]
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "Không có tập tin nào."
        Exit Sub
    End If

 [COLOR="Green"]   'Điền vào mảng myFiles danh sách các tập tin Excel trong thư mục[/COLOR]
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

 [COLOR="Green"]   'Nhằm tăng tốc độ[/COLOR]
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

[COLOR="Green"]    'Thêm vào một workbook với một worksheet[/COLOR]
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

 [COLOR="Green"]   'Duyệt qua các tập tin của mảng myFiles[/COLOR]
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
          [COLOR="Green"]          'if SourceRange use all columns then skip this file[/COLOR]
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Xin lỗi, không có đủ dòng trong sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                      [COLOR="Green"]  'we copy the values from the sourceRange to the destrange[/COLOR]
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
[COLOR="Green"]    'Trả lại các giá trị cho ScreenUpdating, Calculation and EnableEvents[/COLOR]
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

(Sẽ giải thích tiếp)

 

[levanduyet]

Trong các ví dụ trên có dùng hàm RDB_Last

Function [COLOR="Red"]RDB_Last[/COLOR](choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' [COLOR="Blue"]1 = Hàng cuối cùng[/COLOR] (last row)
' [COLOR="Blue"]2 = Cột cuối cùng[/COLOR] (last column)
' [COLOR="Blue"]3 = Ô cuối cùng[/COLOR] (last cell)
' [COLOR="Blue"]rng = là vùng bạn cần xác định 
    Dim lrw As Long
    Dim lcol As Integer

    Select Case choice

    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0

    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0

    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        RDB_Last = rng.Parent.cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0

    End Select
End Function

Trong các ví dụ trên có đoạn mã sau:

FirstCell = "A2"
Set SourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))

Đoạn mã này áp dụng hàm RDB_Last nhằm gán biến cho vùng của worksheet hiện tại (ActiveSheet) từ vị trí ô FirstCell (tức là A2) đến ô cuối cùng.

Các bạn có thể tham khảo thêm ở đây.

 

[levanduyet]

2) Merge một vùng từ tất cả các workbook bạn chọn - Merge a range from every workbook you select (below each other)

Ví dụ này sẽ thực hiện giống như ví dụ ở trên chỉ khi bạn thực hiện mã (run the code) mà bạn có thể chọn các tập tin mà bạn muốn tổng hợp (merge) số liệu.

Tôi sử dụng hàm ChDirNet, do đó bạn có thể thiết lập đường dẫn để bắt đầu hoặc thư mục trên mạng nếu bạn muốn.

Điền đường dẫn đến thư mục chứa các tập tin cần tổng hợp

ChDirNet "C:\Users\Ron\test"

Và thay đổi sheet và vùng của bạn (xem ví dụ đầu tiên)

Chú ý: Copy tất cả đoạn mã sau vào một module

Private Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long

Sub [COLOR="Red"]ChDirNet[/COLOR](szPath As String)
    SetCurrentDirectoryA szPath
End Sub

Sub [COLOR="Red"]Basic_Example_2[/COLOR]()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant


    'Nhằm tăng tốc độ thực hiện
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    SaveDriveDir = CurDir
    ChDirNet "C:\Users\Ron\test" '[COLOR="Blue"]Bạn có thể thay đổi đường dẫn theo ý bạn ở đây[/COLOR]

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then

        'Thêm một workbook mới với một sheet
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1


        'Vòng lập để quét qua các tập tin trong mảng [COLOR="Blue"]array(myFiles)[/COLOR]
        For Fnum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'Nếu SourceRange dùng tất cả các cột thì bỏ qua tập tin này
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy tên tập tin ở cột A
                        With sourceRange
                            BaseWks.cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = FName(Fnum)
                        End With

                        'Khởi tạo biến [COLOR="Blue"]destrange[/COLOR]
                        Set destrange = BaseWks.Range("B" & rnum)

                        'Chúng ta copy các giá trị từ [COLOR="Blue"]sourceRange[/COLOR] vào [COLOR="Blue"]destrange[/COLOR]
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Trả lại tình trạng của  ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub

 

[levanduyet]

3) Merge một vùng từ tất cả các workbook trong một thư mục - Merge a range from all workbooks in a folder (next to each other)

Trong ví dụ này sẽ tổng hợp dữ liệu và đưa vào gần với nhau. Ở cột A bạn thấy dữ liệu từ workbook đầu, ở cột B dữ liệu từ workbook tiếp theo...

Có một vài điều bạn phải thay trước khi thực thi đoạn mã

Thay đổi đường dẫn đến thư mục của bạn

MyPath = "C:\Users\Ron\test"

Tôi dùng sheet đầu tiên của mỗi workbook trong ví dụ (index 1)
Thay sheet index hoặc điền vào tên sheet: mybook.Worksheets("YourSheetName")
Và thay đổi vùng A1:A10 theo vùng của bạn.

Set sourceRange = mybook.Worksheets(1).Range("A1:A10")

Sub [COLOR="Red"]Basic_Example_3[/COLOR]()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceCcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim Cnum As Long, CalcMode As Long

    'Điền đường dẫn đến thư mục chứa các tập tin
    MyPath = "C:\Users\Ron\test"

    'Thêm vào \ vào cuối nếu người dùng quên
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'Trong trường hợp không có tập tin Excel trong thư mục thì thoát thủ tục này
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "Không tìm thấy tập tin nào"
        Exit Sub
    End If

    'Điền vào mảng array(myFiles) với danh sách của các tập tin trong thư mục
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Nhằm tăng tốc độ thực hiện
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Thêm vào một workbook mới với một sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    Cnum = 1

    'Thực hiện đối với từng tập tin trong mảng array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                Set sourceRange = mybook.Worksheets(1).Range("A1:A10")

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all rows then skip this file
                    If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceCcount = sourceRange.Columns.Count

                    If Cnum + SourceCcount >= BaseWks.Columns.Count Then
                        MsgBox "Sorry there are not enough columns in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy tên tập tin vào dòng đầu tiên
                        With sourceRange
                            BaseWks.cells(1, Cnum). _
                                    Resize(, .Columns.Count).Value = MyFiles(Fnum)
                        End With

                        'Thiết lập [COLOR="Blue"]destrange[/COLOR]
                        Set destrange = BaseWks.cells(2, Cnum)

                        'Chúng ta copy các giá trị từ [COLOR="Blue"]sourceRange [/COLOR]vào [COLOR="Blue"]destrange[/COLOR]
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        Cnum = Cnum + SourceCcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Trả về các giá trị cho ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub

 

[levanduyet]

4) Merge một vùng từ tất cả các workbook trong một thư mục với AutoFilter - Merge a range from all workbooks in a folder with AutoFilter

Trong ví dụ này sẽ lọc một vùng trên một worksheet trong nhiều workbook cùng thư mục và copy các giá trị lọc được vào workbook mới.

Có 5 dòng mã bạn phải thay đổi trước khi thực hiện đoạn mã này

Sub Basic_Example_4()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim rng As Range, SearchValue As String
    Dim FilterField As Integer, RangeAddress As String
    Dim ShName As Variant, RwCount As Long

    '**********************************************************
    '***Thay đổi 5 dòng mã này trước khi bạn thực thi đoạn mã tiếp theo           ***
    '**********************************************************

    'Điền vào đường dẫn đến thư mục chứa các tập tin
    MyPath = "C:\Users\Ron\test"

    'Điền vào tên sheet chứa dữ liệu trên mỗi workbook
    'Sử dụng [COLOR="Blue"]ShName = "Sheet1"[/COLOR] nếu bạn muốn dùng một tên sheet thay vì dùng index
    'We use the first sheet in every workbook in this example(I use the index)
    ShName = 1

    'Điền vào vùng lọc dữ liệu : A1 là header của cột đầu tiên và G là
    'cột cuối cùng trong vùng và nó sẽ lọc tất cả các hàng trên sheet
    'Bạn cũng có thể dùng một [COLOR="Blue"]fixed range[/COLOR] như [COLOR="Blue"]A1:G2500[/COLOR] nếu bạn muốn
    RangeAddress = Range("A1:G" & Rows.Count).Address

    'Trường mà bạn muốn lọc trong vùng  ( 1 = cột A trong ví dụ này
    'bởi vì vùng lọc bắt đầu ở cột A
    FilterField = 1

    'Giá trị cần lọc 
    'Hoặc dùng [COLOR="Blue"]wildcards[/COLOR] như [COLOR="Blue"]"*ron"[/COLOR] cho các ô bắt đầu với [COLOR="Blue"]ron[/COLOR] hay dùng
    '[COLOR="Blue"]"*ron*"[/COLOR] nếu bạn muốn lọc những ô có chứa chữa [COLOR="Blue"]ron[/COLOR]
    SearchValue = "ron"

    '**********************************************************
    '**********************************************************


    'Thêm \ 
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'Nếu không có tập tin Excel trong thư mục thì thoát thủ tục
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "Không tìm thấy tập tin nào."
        Exit Sub
    End If

    'Điền vào mảng array(myFiles) với danh sách tập tin Excel trong thư mục
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Tăng tốc
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Thêm một workbook mới với một sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    'Duyệt qua tất cả các tập tin trong mảng array(myFiles)
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                'Thiết lập vùng lọc
                With mybook.Worksheets(ShName)
                    Set sourceRange = .Range(RangeAddress)
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then
                    'Tìm hàng cuối cùng trong BaseWks
                    rnum = RDB_Last(1, BaseWks.Cells) + 1

                    With sourceRange.Parent
                        Set rng = Nothing

                        'Đầy tiên, xóa bỏ AutoFilter
                        .AutoFilterMode = False

                        'Lọc vùng trên cột FilterField
                        sourceRange.AutoFilter Field:=FilterField, _
                                               Criteria1:=SearchValue

                        With .AutoFilter.Range

                            'Kiểm tra nếu có kết quả sau khi  AutoFilter
                            RwCount = .Columns(1).Cells. _
                                      SpecialCells(xlCellTypeVisible).Cells.Count - 1

                            If RwCount = 0 Then
                                'Không có dữ liệu, chỉ có header
                            Else
                                ' Thiết lập vùng không có Header
                                Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _
                                          Offset(1, 0).SpecialCells(xlCellTypeVisible)


                                'Copy vùng và tên tập tin vào cột A
                                If rnum + RwCount < BaseWks.Rows.Count Then
                                    BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
                                          = mybook.Name
                                    rng.Copy BaseWks.Cells(rnum, "B")
                                End If
                            End If

                        End With

                        'Xóa bỏ AutoFilter
                        .AutoFilterMode = False

                    End With
                End If

                'Đóng workbook nhưng không lưu
                mybook.Close savechanges:=False
            End If

            'Mở workbook tiếp theo
        Next FNum

        'Thiết lập độ rộng cột cho workbook mới
        BaseWks.Columns.AutoFit
        MsgBox "Look at the merge results in the new workbook after you click on OK"
    End If

    'Trả về các giá trị cho ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

 

[levanduyet]

5) Tổng hợp dữ liệu dùng Consolidate

Chắc các bạn đều biết công cụ Consolidate, nó có khả năng tổng hợp dữ liệu từ nhiều sheet, thậm chí từ nhiều file
Việc viết code có thể dựa trên cơ sơ Record macro rồi chỉnh lại

Vấn đề ở đây là tôi có 4 file nằm trong 1 thư mục, tôi muốn dùng Consolidate để tổng hợp nó ra 1 file khác mà không cần đến 1 vòng lập nào
Các bạn hãy thử xem

Có file đính kèm, ra kết quả giống như trong file ConsolMutiFiles.xls là xem như thành công! (các file con nằm trong thư mục Source)
Lưu ý:
- Ta chỉ biết các file con nằm trong 1 thư mục chỉ định trước chứ không biết có tổng cộng bao nhiêu file con và tên file con là gì đâu nha
- Biết trước: các file con nằm trong thư mục Source (là thư mục con của thư mục chứa file ConsolMutiFiles.xls)
- Biết trước: Dữ liệu cần tổng hợp trong các file con nằm ở "Sheet1", vùng "A2:B30"

Cũng đơn giản thôi! Thuật toán dựa vào hàm FILES của macro4, nó có khả năng lấy list file trong 1 thư mục mà không cần vòng lập:

Sub ConsolMutiFiles(Folder As String, ShName As String, SrcRng As String, Target As Range)
  Dim Temp As String
  Temp = ShName & "'!" & Range(SrcRng).Address(, , 2)
  If Right(Folder, 1) <> "\" Then Folder = Folder & ""
  ActiveWorkbook.Names.Add "Arr", "=""" & Folder & "[""&Files(""" & Folder & "*.*"")&""]" & Temp & """"
  Target.Consolidate Evaluate("Arr"), 9, 0, 1
  ActiveWorkbook.Names("Arr").Delete
End Sub

Sub Test()
  Dim Folder As String, ShName As String, SrcRng As String
  Range("A2:B1000").ClearContents
  With CreateObject("Shell.Application")
    On Error Resume Next
    Folder = .BrowseForFolder(0, "", 1).Self.Path
  End With
  ShName = "Sheet1": SrcRng = "A2:B30"
  ConsolMutiFiles Folder, ShName, SrcRng, Range("A2")
End Sub

Vụ bẩy lỗi gì đó các bạn tự làm nha!

Link tại đây.