Dữ liệu của bạn nên dùng Pivot Table là nhanh và dễ sử dụng nhất
Mỗi ô công thức Sumproduct() bạn dùng đến số 5000, Bạn tính xem bao nhiêu ô nhân với 5000 dòng như vậy, không "Rùa" mới lạ.
Sub ThongKe_Dhn46_VBA()
Dim i As Long, k As Long, MH As Long, Ngay1 As Long, Ngay2 As Long
Dim TenKH As Object
Dim Arr, sArr
With Sheets("data")
Arr = .Range(.[A3], .[A65000].End(xlUp)).Resize(, 9).Value
End With
ReDim sArr(1 To UBound(Arr, 1), 1 To 12)
Set TenKH = CreateObject("Scripting.Dictionary") 'Tao Dictionary
With Sheets("TK THEO NGAY")
Ngay1 = .[H2].Value2: Ngay2 = .[J2].Value2 'Dat cac vi tri Ngay bat dau, ket thuc
For i = 1 To UBound(Arr, 1) 'Duyet 1 vong du lieu
If Arr(i, 1) >= Ngay1 And Arr(i, 1) <= Ngay2 Then 'Neu thoa man dieu kien ngay
If Not TenKH.Exists(Arr(i, 5)) Then 'Neu Ten khach hang chua xuat hien trong Dictionary
k = k + 1
TenKH.Add Arr(i, 5), k 'Add vao Dic
sArr(k, 1) = Arr(i, 5) 'Add Ten khach hang vao cot 1 ket qua
For MH = 3 To .[C5].End(xlToRight).Column 'Duyet qua cac ten hang
If UCase(Arr(i, 6)) = UCase(.Cells(5, MH)) Then 'Neu ten hang trung sheet TK theo ngay
sArr(k, MH - 1) = Arr(i, 9): Exit For 'Them so luong vao cot tuong ung
End If
Next
Else 'Neu ten khach hang da co trong Dic
For MH = 3 To .[C5].End(xlToRight).Column 'Duyet qua cac ten hang
If UCase(Arr(i, 6)) = UCase(.Cells(5, MH)) Then
sArr(TenKH.Item(Arr(i, 5)), MH - 1) = Arr(i, 9) + Arr(i, 9) 'Cong them so luong vao cot tuong ung, lay dong k trong dic
Exit For
End If
Next
End If
End If
Next
.[B6:M65000].ClearContents
.[B6].Resize(k, 12).Value = sArr
.[B6].Resize(k, 12).Sort Key1:=.[B6]
End With
Set TenKH = Nothing
End SubSub Thongke_Dhn46()
Dim Str As String, adoConn As Object, adoRS As Object, i As Long
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
For i = 3 To Sheet2.Range("C5").End(xlToRight).Column
Str = Str & "Sum(iif(f6='" & Sheet2.Cells(5, i) & "',f9)) as Mh" & i & ","
Next
Str = Left(Str, Len(Str) - 1)
With adoRS
.ActiveConnection = adoConn
.Open "Select f5," & Str _
& " From [Data$A3:L65536] Where f1 >=" _
& Sheet2.[H2].Value2 & " And f1<=" _
& Sheet2.[J2].Value2 & " Group by f5 " _
& "Order by f5"
End With
With Sheet2
.[B6:M100].ClearContents
.[B6].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing
End SubDạ, code trên chưa chắc đã duyệt 1000*11 lần các mã hàng đâu ạ. Em có đưa 2 cái Exit For vào mong là 1000* (<11) lần thầy ah.
Tôi copy nguyên dữ liệu bên trên xuống đến dòng 5000, code của bạn chạy trong thời gian 0.6875 giây, code của tôi là 0.0859 giây. nhanh hơn gấp 8 lần.
Em chưa Test tốc độ nhưng thói quen là: hạn chế tạo Object trong quá trình viết code, không biết vậy có đúng không nữa.
-----------------------
Thay Sub cũ bằng Sub này xem sao, thêm bi nhiêu mã hàng cần tính thì thêm, miễn là tên mã hàng ở dòng 5 sheet TK THEO NGAY phải giống chính xác như tên hàng có trong cột F của sheet Data, "Ống cống" với ng cóng" là "tèo"
Public Sub GPE()
Application.ScreenUpdating = False
Dim TenKH As Object, TenHH As Object, sArr(), dArr(), i As Long, k As Long, t As Variant
Dim TemKH As String, TemHH As String, Cll As Range, Ngay1 As Long, Ngay2 As Long, C As Long
Set TenKH = CreateObject("Scripting.Dictionary")
Set TenHH = CreateObject("Scripting.Dictionary")
On Error Resume Next
t = Timer
With Sheets("data")
sArr = .Range(.[A3], .[A65000].End(xlUp)).Resize(, 9).Value
End With
With Sheets("TK THEO NGAY")
C = .[IV5].End(xlToLeft).Column
Ngay1 = .[H2].Value: Ngay2 = .[J2].Value
ReDim dArr(1 To UBound(sArr, 1), 1 To C - 1)
For Each Cll In .[C5].Resize(, C)
If Not TenHH.Exists(UCase(Cll.Value)) Then TenHH.Add UCase(Cll.Value), Cll.Column - 1
Next
For i = 1 To UBound(sArr, 1)
If sArr(i, 1) >= Ngay1 And sArr(i, 1) <= Ngay2 Then
TemKH = UCase(sArr(i, 5)): TemHH = UCase(sArr(i, 6))
If Not TenKH.Exists(TemKH) Then
k = k + 1
TenKH.Add TemKH, k
dArr(k, 1) = sArr(i, 5)
If TenHH.Exists(TemHH) Then dArr(k, TenHH.Item(TemHH)) = sArr(i, 9)
Else
If TenHH.Exists(TemHH) Then dArr(TenKH.Item(TemKH), TenHH.Item(TemHH)) = dArr(TenKH.Item(TemKH), TenHH.Item(TemHH)) + sArr(i, 9)
End If
End If
Next i
.[B6:B65000].Resize(, C).ClearContents
.[B6].Resize(k, C - 1).Value = dArr
.[B6].Resize(k, C - 1).Sort Key1:=.[B6]
End With
Set TenKH = Nothing
Set TenHH = Nothing
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
