Tổng hợp dữ liệu từ nhiều file nhỏ vào 1 file ? (1 người xem)

[Hoàng Nhật Phương]

Xin chào tất cả các bạn,
Oanh Thơ đang vướng mắc một vấn đề như đã nêu tại tiêu đề.
Cụ thể như sau:

Trong cùng 1 thư mục Oanh Thơ có rất nhiều file bao gồm cả file Tonghop.
Và Oanh Thơ muốn tổng hợp dữ liệu từ các file chi tiết được liệt kê sau vào file tổng hợp: a1,a2,a3,b,f
Còn các file khác như:x,no tuy trong cùng thư mục nhưng không tổng hợp vào file Tonghop

Có 2 lưu ý ạ:
1.Các file chi tiết có password sheet
2.Dữ liệu ở các file chi tiết thường xuyên thay đổi nhiều hoặc ít.( về số cột thì giữ nguyên nhưng về dòng thường xuyên thay đổi)

Và Oanh Thơ cũng đã minh họa sẵn dữ liệu sau khi được tổng hợp từ các file được liệt kê ra vào file Tonghop như trong file Tonghop dinh kèm.

Phiền các bạn xem file và dành chút thời gian xem và giúp đỡ cho Oanh Thơ với ạ.
Trân trọng cảm ơn.

 

[quanluu]

Xin chào tất cả các bạn,
Oanh Thơ đang vướng mắc một vấn đề như đã nêu tại tiêu đề.
Cụ thể như sau:

Trong cùng 1 thư mục Oanh Thơ có rất nhiều file bao gồm cả file Tonghop.
Và Oanh Thơ muốn tổng hợp dữ liệu từ các file chi tiết được liệt kê sau vào file tổng hợp: a1,a2,a3,b,f
Còn các file khác như:x,no tuy trong cùng thư mục nhưng không tổng hợp vào file Tonghop

Có 2 lưu ý ạ:
1.Các file chi tiết có password sheet
2.Dữ liệu ở các file chi tiết thường xuyên thay đổi nhiều hoặc ít.( về số cột thì giữ nguyên nhưng về dòng thường xuyên thay đổi)

Và Oanh Thơ cũng đã minh họa sẵn dữ liệu sau khi được tổng hợp từ các file được liệt kê ra vào file Tonghop như trong file Tonghop dinh kèm.

Phiền các bạn xem file và dành chút thời gian xem và giúp đỡ cho Oanh Thơ với ạ.
Trân trọng cảm ơn.

Bạn thử với code này

Sub GhepFile()
Dim WB As Workbook, FSO As Object, FileItem As Object
Dim lr As Integer, MainWB As Workbook
Application.ScreenUpdating = False
    Range("C5:I6500").ClearContents
    Set MainWB = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each FileItem In FSO.GetFolder(ThisWorkbook.Path).Files
        If FileItem.Name <> "TongHop.xlsx" And Left(FileItem.Name, 1) <> "~" And FileItem.Name <> "x.xlsx" And FileItem.Name <> "no.xlsx" Then
            Set WB = Workbooks.Open(FileItem.Path)
            With WB.Sheets("Sheet1")
                lr = .Range("B65000").End(3).Row
                .Range("B3:H" & lr).Copy MainWB.ActiveSheet.Range("C" & MainWB.ActiveSheet.Range("C65000").End(3).Row + 1)            
            End With
            WB.Close False
        End If
    Next FileItem
    Set FileItem = Nothing
    Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

 

[Kiều Mạnh]

Bài này nhiều File và không xác đinh số lượng File và tên File như vậy Xài ADO + Fso chạy cái dẹt xong

Fso = duyệt File

ADO = Tổnghợp File

Tìm trong mớ bài của mình có code như vậy ...

Nếu ko thích ADO thì xài FormulaArray cũng ok vậy....

 

[Kiều Mạnh]

Xin Lỗi Gửi hai lần ....nhờ Mod xóa dùm bài này

 

[Hoàng Nhật Phương]

Bạn thử với code này

Sub GhepFile()
Dim WB As Workbook, FSO As Object, FileItem As Object
Dim lr As Integer, MainWB As Workbook
Application.ScreenUpdating = False
    Range("C5:I6500").ClearContents
    Set MainWB = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each FileItem In FSO.GetFolder(ThisWorkbook.Path).Files
        If FileItem.Name <> "TongHop.xlsx" And Left(FileItem.Name, 1) <> "~" And FileItem.Name <> "x.xlsx" And FileItem.Name <> "no.xlsx" Then
            Set WB = Workbooks.Open(FileItem.Path)
            With WB.Sheets("Sheet1")
                lr = .Range("B65000").End(3).Row
                .Range("B3:H" & lr).Copy MainWB.ActiveSheet.Range("C" & MainWB.ActiveSheet.Range("C65000").End(3).Row + 1)            
            End With
            WB.Close False
        End If
    Next FileItem
    Set FileItem = Nothing
    Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

Chào bạn,
Xin cảm ơn bạn nhiều nhé, Oanh Thơ đã thử trên file gửi kèm kết quả thật tuyệt vời.
Nếu trong quá trình áp dụng có gì vướng mắc nhờ bạn hỗ trợ thêm nhé.

Trân trọng

 

[Hoàng Nhật Phương]

Bài này nhiều File và không xác đinh số lượng File và tên File như vậy Xài ADO + Fso chạy cái dẹt xong

Fso = duyệt File

ADO = Tổnghợp File

Tìm trong mớ bài của mình có code như vậy ...

Nếu ko thích ADO thì xài FormulaArray cũng ok vậy....

Chào bạn,

Đúng như bạn phán đoán.
Thư mục của Oanh Thơ có rất nhiều file vì thế Oanh Thơ mới nêu cụ thể file nào được cập nhật và file nào không được..

Nếu không phiền bạn có thể chỉ rõ cho Oanh Thơ thực hiện bài này theo cách của bạn được không ạ?
Cảm ơn bạn nhiều.
O.Thơ

 

[Kiều Mạnh]

Chào bạn,

Đúng như bạn phán đoán.
Thư mục của Oanh Thơ có rất nhiều file vì thế Oanh Thơ mới nêu cụ thể file nào được cập nhật và file nào không được..

Nếu không phiền bạn có thể chỉ rõ cho Oanh Thơ thực hiện bài này theo cách của bạn được không ạ?
Cảm ơn bạn nhiều.
O.Thơ

Bạn thử code sau ... có trên GPE hết rồi có điều Bạn ngại tìm hay sao ý
Xem hướng dẫn kèm theo Sub Main

Public Sub GetDataFiles(strPath As String, SheetName As String, datarange As String, Col As Long, Target As Range)
    On Error Resume Next ''Xu ly loi khi co File Sheet Empty
    Application.ScreenUpdating = False
    Dim Fso As Object, objFile As Object, data$, Sht$
    Dim Res(), arr(), i&, j&, k&, Cols&, FullPath$, FilePath$
    Dim Cels As String: Cels = Left(datarange, 1)
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each objFile In Fso.GetFolder(strPath).Files
        If Fso.GetExtensionName(objFile) Like "xls*" Then
            If Left(objFile.Name, 2) <> "~$" Then
                If objFile.Name <> ThisWorkbook.Name Then
                    FullPath = "'" & strPath & "\[" & objFile.Name & "]" & SheetName & "'!"
                    Rows(1).End(2) = "=IFERROR(LOOKUP(2,1/(" & FullPath _
                        & Cels & "1:" & Cels & "65536<>""""),ROW(1:65536)),0)"
                    data = datarange & Rows(1).End(2)
                    FilePath = "=" & FullPath & data
                    With Target.Range(data)
                        .FormulaArray = FilePath
                        Res = .Value
                        .ClearContents
                    End With
                    Cols = UBound(Res, 2)
                    ReDim Preserve arr(1 To 65536, 1 To Cols)
                    For i = 1 To UBound(Res)
                        If Res(i, Col) <> Empty Then
                            k = k + 1
                            For j = 1 To UBound(Res, 2)
                                arr(k, j) = Res(i, j)
                            Next
                        End If
                    Next
                End If
            End If
        End If
    Next
    If k Then Target.Resize(k, UBound(Res, 2)).Value = arr
    Set Fso = Nothing
    Rows(1).End(2) = Empty
    Application.AskToUpdateLinks = False
    Application.ScreenUpdating = True
End Sub

[COLOR=#ff0000][B]Chạy Cái Này[/B][/COLOR]


Public Sub Main()
    Dim path As String, Sht As String, data As String
    path = ThisWorkbook.path                ''Noi luu File can tong Hop(duong dan File)
    Sht = "Sheet1"                          ''Ten Sheet can lay
    data = ("B3:H")                         ''Vung du lieu can lay chi Can B3 con H ko xac dinh co nhieu lay nhieu
    ActiveSheet.UsedRange.ClearContents
    GetDataFiles path, Sht, data, 2, [C5]
    '' 2 = Loc theo cot thu 2 co du lieu ...Cot B la 1 va C la 2 Theo Data = ("B3:H")
    '' [C5] = Noi gan ket Qua xuong Sheet
End Sub

 

[doveandrose]

Sao cứ thích phức tạp vấn đề & dùng "Đao to búa lớn thế nhỉ?" Cứ truyền thống, đơn giản mà mần thôi.

Ồ cảm ơn anh HpKhuong , tuy rằng code sẽ không sử dụng được nhưng được anh giúp ấy là vui rồi . hi hi

 

[Kiều Mạnh]

Sao cứ thích phức tạp vấn đề & dùng "Đao to búa lớn thế nhỉ?" Cứ truyền thống, đơn giản mà mần thôi.

Public Sub GPE()
Dim sArr, dArr(1 To 10000, 1 To 7), tArr, I As Long, J As Long, K As Long, Path As String, T As Long, Wb As Workbook
Path = ThisWorkbook.Path
tArr = Array("a1", "a2", "a3", "b", "f")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For T = 0 To UBound(tArr)
Set Wb = Workbooks.Open(Path & "\" & tArr(T) & ".xlsx")
    With Wb.Sheets(1)
        .Unprotect
        sArr = .Range("B3").CurrentRegion.Value
        For I = 1 To UBound(sArr)
            K = K + 1
            For J = 1 To UBound(sArr, 2)
                dArr(K, J) = sArr(I, J)
            Next J
        Next I
        .Protect
    End With
Wb.Close
Next T
With Sheet1
    .Range("C5").CurrentRegion.ClearContents
    .Range("C5").Resize(K, 7).Value = dArr
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Biết vậy mà ... nhưng lỡ người ta có 100 file mà Workbooks.Open chạy code xong ra ngoài uống cafe xong vào coi kết quả quá ....tại thấy người ta đưa nhiều file mới viết vây ...

Nhưng code bài 7 sẻ lỗi trên 1 vài máy ....hahaha ...tiện đây Mạnh Úp lên cho họ test để điều chỉnh đó mà ...1 tên bắn 2 con chim thôi ....Bạn hiền

 

[Hoàng Nhật Phương]

Hihi,
Oanh Thơ xin cảm ơn các bạn rất nhiều vì đã hỗ trợ ạ.
Đúng như những gì bạn hpKhuong nhận xét: về code thì Oanh Thơ không hiểu gì luôn rồi thậm trí đưa vào áp dụng được cũng đã cảm thấy còn rất khó khăn.. (

Hiện thời Oanh Thơ mới áp được code ở bài #2 và #8 ,
Còn #7 thực sự là ... hichic. Oanh Thơ xin lỗi,Oanh Thơ sẽ cố gắng tìm hiểu thêm.Có thể đó là 1 giải pháp có thể sử dụng được trong nhiều trường hợp vì vậy code mới phức tạp đến như vậy.

Hi có 2 bạn: hpKhuong và doveandrose cùng tham gia Oanh Thơ cảm thấy vui và yên tâm thật nhiều.

Một lần nữa xin cảm ơn diễn đàn và cảm ơn các bạn nhiều nhiều.

 

[Kiều Mạnh]

Ơ kìa 2 Anh hãy copy Bài #12 Paste qua Web sau nghe Em nói he .....

http://www.vnspeech.com/?view=article&id=47