Tổng hợp dữ liệu theo nhóm (từ nhiều file)?

Chia sẻ bởi:hands

★★★★★

‹ Xin các đổi tên hàng loạt folder... Lấy dữ liệu từ nhiều vào 1... ›

Quảng cáo

Xin chào tất cả các bạn,

Như tiêu Oanh Thơ đã nêu,vấn đề chi tiết xin được nêu cụ thể trong tập tin.
Nhờ các bạn giúp đỡ cho tôi trường hợp trong tập tin gửi kèm ạ.

Bạn thử dùng code sau xem đúng chưa nhé!

Sub SummaryData()
    Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
    Dim sArr(), dArr(1 To 10000, 1 To 6)
    Dim I As Long, K As Long, lC As Long

Sheet1.Range("B7:G65000").ClearContents

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls*", 1
        If Not .Show = -1 Then
            MsgBox "Ban chua chon file", vbCritical, "GPE"
            Exit Sub
        End If

Application.DisplayAlerts = False
        For Each Item In .SelectedItems
            Set Wk = Workbooks.Open(Item)
            For Each Ws In Wk.Sheets
                With Ws
                    WsName = .Name
                    .Columns("A:G").Delete: .Rows("8:9").Delete
                    lC = .Range("A7").End(xlToRight).Column
                    sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
                    For I = 2 To UBound(sArr, 2)
                        K = K + 1
                        dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I)
                        dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I)
                    Next I
                End With
            Next Ws
            Wk.Close False
        Next Item
        Application.DisplayAlerts = False
    End With
    Sheet1.Range("B7").Resize(K, 6) = dArr
    MsgBox "Done", vbInformation, "GPE"
End Sub