Nhờ viết code tổng hợp dữ liệu

[Erebus]

Em chào các bác ạ !
Em đang có một bài toán khó như sau, em có các sheet dữ liệu sheet1,sheet2,sheet3 và cần tổng hợp lại thành một báo cáo như tệp đính kèm.
Vì dữ liệu rất lớn lên đến mấy trăm nghìn dòng nên dùng sumifs cần chạy rất lâu
Nhờ các bác viết giúp em code tự động tổng hợp dữ liệu từ các sheet vào với ạ

 

[Ronaldinho7]

Em chào bác, bác ơi em có thể xin liên hệ bác được không ah, em có chút việc nhờ bác xem qua ạ

Nếu thông tin không bảo mật thì bạn cứ gửi lên đây để mọi người hỗ trợ nhé!
Còn không thì bạn gửi về: taydo@vnmatsuya.com
Trong khả năng, nếu giúp được bạn tôi sẽ giúp!

 

[HUONGHCKT]

Em chào các bác ạ !
Em đang có một bài toán khó như sau, em có các sheet dữ liệu sheet1,sheet2,sheet3 và cần tổng hợp lại thành một báo cáo như tệp đính kèm.
Vì dữ liệu rất lớn lên đến mấy trăm nghìn dòng nên dùng sumifs cần chạy rất lâu
Nhờ các bác viết giúp em code tự động tổng hợp dữ liệu từ các sheet vào với ạ

Góp vui cho thêm phần rộn rã.

Option Explicit

Sub TongHop()
Dim i&, J&, Lr&, t&, k&, R&, Col&, Tmr As Double
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr(), KQ(), s
Dim Dic As Object, key As String
Dim Dict As Object, Temp As String
 Tmr = Timer()
Set Sh = Sheets("Report")
ReDim KQ(1 To 1000000, 1 To 7)
ReDim TieuDe(1 To 1, 1 To 7)
Set Dic = CreateObject("Scripting.Dictionary")
Set Dict = CreateObject("Scripting.Dictionary")

For Each Ws In Worksheets
    If Ws.Name <> Sh.Name Then
        Lr = Ws.Cells(1000000, 1).End(xlUp).Row
        Arr = Ws.Range("A3:D" & Lr).Value: R = UBound(Arr)
        For i = 1 To R
            Temp = Arr(i, 4)
            If Not Dict.Exists(Temp) Then Col = Col + 1: Dict.Add (Temp), Col: TieuDe(1, Col + 1) = Temp
            key = Arr(i, 2)
            If Not Dic.Exists(key) Then
                t = t + 1: Dic.Add (key), t
                KQ(t, 1) = key
                KQ(t, Dict.Item(Temp) + 1) = Arr(i, 3)
            Else
                k = Dic.Item(key)
                KQ(k, Dict.Item(Temp) + 1) = KQ(k, Dict.Item(Temp) + 1) + Arr(i, 3)
            End If
                KQ(t, 7) = (KQ(t, 5) + KQ(t, 6)) - (KQ(t, 2) + KQ(t, 3) + KQ(t, 4))
        Next i
    End If
Next Ws
TieuDe(1, 1) = "Item": TieuDe(1, Col + 2) = "Total"
If t Then
    Sh.Range("A2").Resize(1000000, 7).ClearContents
    Sh.Range("A2").Resize(1, Col + 2) = TieuDe
    Sh.Range("A3").Resize(t, 7) = KQ
End If
Set Dic = Nothing: Set Dict = Nothing
 MsgBox Timer() - Tmr ' MsgBox "DONE"
End Sub

 

[Erebus]

Bạn thử code sau:

Sub TrichLoc_HLMT()
    Dim cn As String, strSQL As String, i As Integer
    strSQL = "Select [DATE],[ITEM],[Qty],[Type] From [Jan$] Where [Qty] is not null"
    strSQL = strSQL & " Union All Select [DATE],[ITEM],[Qty],[Type] From [Mar$] Where [Qty] is not null"
    strSQL = strSQL & " Union All Select [DATE],[ITEM],[Qty],[Type] From [May$] Where [Qty] is not null"
    cn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
    With CreateObject("ADODB.Recordset")
        .Open ("TRANSFORM SUM([Qty]) Select [ITEM], Sum(Qty) As Total From (" & strSQL & ") GROUP BY  [ITEM] PIVOT [Type]"), cn
        For i = 0 To .Fields.Count - 1
            Sheet4.Cells(2, i + 12) = .Fields(i).Name
        Next
        Sheet4.Range("L3").CopyFromRecordset .DataSource
    End With
End Sub

Cột 'Total' của bạn phải bằng các cột cộng lại chứ bạn?

Đúng rồi bác ạ,
Code của bác là dạng mà đối với em là hoàn toàn mới lạ. nhưng đã ra kết quả đúng rồi ạ
E cảm ơn bác rất nhiều