Tổng hợp dữ liệu từ nhiều file (1 người xem)

[Ngoc Nguyen X]

Chào mọi người.

Em muốn xin giúp em đoạn code VBA để tổng hợp dữ liệu từ 1 sheet cố định trong nhiều file (cấu trúc giống nhau) vào 1 file tổng hợp. Các file lấy dữ liệu e đều để trong cùng 1 folder. Vì em có rất nhiều file cần tổng hợp nên nhờ các bác giúp em đoạn code VBA ạ.

Như vd, e post lên 2 file nguồn cần lấy dữ liệu trong Sheet "Measurements", tổng hợp về file All Measurements Data ạ.

Em chân thành cảm ơn ạ.

 

[Nhattanktnn]

Chào mọi người.

Em muốn xin giúp em đoạn code VBA để tổng hợp dữ liệu từ 1 sheet cố định trong nhiều file (cấu trúc giống nhau) vào 1 file tổng hợp. Các file lấy dữ liệu e đều để trong cùng 1 folder. Vì em có rất nhiều file cần tổng hợp nên nhờ các bác giúp em đoạn code VBA ạ.

Như vd, e post lên 2 file nguồn cần lấy dữ liệu trong Sheet "Measurements", tổng hợp về file All Measurements Data ạ.

Em chân thành cảm ơn ạ.

Bỏ tất cả file con vào 1 folder, chạy code dưới:

Option Explicit
Sub GetData()
Dim dWb As Workbook, Fso As Object, Chk As Boolean, Fpath As String, I As Long
Dim NewWb As Workbook, File As Object, Lr_dWb As Long, Lr_NewWb As Long
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set dWb = ThisWorkbook
dWb.Sheets("All Information").Rows("2:100000").Clear
With Application.FileDialog(msoFileDialogFolderPicker)
    Chk = .Show
    If Not Chk Then Exit Sub
    Fpath = .SelectedItems(1)
End With
For Each File In Fso.getfolder(Fpath).Files
    Lr_dWb = dWb.Sheets("All Information").Range("C" & Rows.Count).End(xlUp).Row
    If File.Name <> dWb.Name And InStr(Fso.getextensionname(File), "xls") > 0 And Left(File.Name, 1) <> "~" Then
        Workbooks.Open File
        Set NewWb = ActiveWorkbook
        With NewWb.Sheets("Measurements")
            Lr_NewWb = .Range("C" & Rows.Count).End(xlUp).Row
            If Lr_NewWb < 3 Then GoTo NextFile
            .Rows(3 & ":" & Lr_NewWb).Copy dWb.Sheets("All Information").Rows(Lr_dWb + 1)
        End With
        With dWb.Sheets("All Information")
            For I = Lr_dWb + 1 To Lr_dWb + Lr_NewWb - 2
                .Cells(I, 1) = NewWb.Name
            Next
        End With
NextFile:
    NewWb.Close False
    End If
Next
Application.ScreenUpdating = True
End Sub

 

[Ngoc Nguyen X]

Bỏ tất cả file con vào 1 folder, chạy code dưới:

Option Explicit
Sub GetData()
Dim dWb As Workbook, Fso As Object, Chk As Boolean, Fpath As String, I As Long
Dim NewWb As Workbook, File As Object, Lr_dWb As Long, Lr_NewWb As Long
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set dWb = ThisWorkbook
dWb.Sheets("All Information").Rows("2:100000").Clear
With Application.FileDialog(msoFileDialogFolderPicker)
    Chk = .Show
    If Not Chk Then Exit Sub
    Fpath = .SelectedItems(1)
End With
For Each File In Fso.getfolder(Fpath).Files
    Lr_dWb = dWb.Sheets("All Information").Range("C" & Rows.Count).End(xlUp).Row
    If File.Name <> dWb.Name And InStr(Fso.getextensionname(File), "xls") > 0 And Left(File.Name, 1) <> "~" Then
        Workbooks.Open File
        Set NewWb = ActiveWorkbook
        With NewWb.Sheets("Measurements")
            Lr_NewWb = .Range("C" & Rows.Count).End(xlUp).Row
            If Lr_NewWb < 3 Then GoTo NextFile
            .Rows(3 & ":" & Lr_NewWb).Copy dWb.Sheets("All Information").Rows(Lr_dWb + 1)
        End With
        With dWb.Sheets("All Information")
            For I = Lr_dWb + 1 To Lr_dWb + Lr_NewWb - 2
                .Cells(I, 1) = NewWb.Name
            Next
        End With
NextFile:
    NewWb.Close False
    End If
Next
Application.ScreenUpdating = True
End Sub

Em cảm ơn nhiều ạ.