Giúp em viết code cho hàm SUMPRODUCT này với ạ.

[nguyen_sammi]

File em dữ liệu rất nhiều, nếu xài SUMPRODUCT kéo hết 1 bảng tính thì xử lý rất rất chậm, huhu...
Anh chị có thể viết dùm em code của hàm này ko? Nhấn nút UPDATE thì dữ liệu tự động sumproduct lại.
Em xóa bớt dữ liệu cho nhẹ file, các anh chị viết dùm em nhé.
Em cám ơn rất nhiều ạ.

 

[Ba Tê]

File em dữ liệu rất nhiều, nếu xài SUMPRODUCT kéo hết 1 bảng tính thì xử lý rất rất chậm, huhu...
Anh chị có thể viết dùm em code của hàm này ko? Nhấn nút UPDATE thì dữ liệu tự động sumproduct lại.
Em xóa bớt dữ liệu cho nhẹ file, các anh chị viết dùm em nhé.
Em cám ơn rất nhiều ạ.

Thử với code này xem:

Public Sub GPE()
Dim Rng(), Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long, Dat As Variant, t As Variant
Dim Arr(1 To 65000, 1 To 240), Cot As Long, Ws As Worksheet, Tem As Variant, Dong, TS As Long
t = Timer
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("N-X XOP")
    Rng = .Range(.[C8], .[C65000].End(xlUp)).Resize(, 3).Value
        For I = 1 To UBound(Rng, 1)
            Tem = Rng(I, 1)
            If Not Dic1.Exists(Tem) Then
                K = K + 1: Dic1.Add Tem, K
                Arr(K, 1) = Rng(I, 3)
                For J = 4 To 240 Step 3
                    Arr(K, J) = "=SUM(RC[-3]:RC[-2])-RC[-1]"
                Next J
            End If
        Next I
    Rng = .[F6:IV6].Value
        For I = 1 To UBound(Rng, 2)
            Tem = Rng(1, I)
            If Tem <> "" Then
                Cot = I + 1
                Dic2.Add Tem, Cot
            End If
        Next I
End With
Set Ws = Sheets("NHAN HANG XOP")
Rng = Ws.Range(Ws.[B11], Ws.[B65000].End(xlUp)).Resize(, 8).Value
    For I = 1 To UBound(Rng, 1)
        Dat = DateSerial(Year(Rng(I, 1)), Month(Rng(I, 1)), 1)
        Cot = Dic2.Item(Dat)
        If Cot > TS Then TS = Cot
        If Dic1.Exists(Rng(I, 6)) Then
            Tem = Rng(I, 6): Dong = Dic1.Item(Tem)
            Arr(Dong, Cot) = Arr(Dong, Cot) + Rng(I, 8)
        End If
    Next I
Set Ws = Sheets("XUAT HANG XOP")
Rng = Ws.Range(Ws.[A11], Ws.[A65000].End(xlUp)).Resize(, 5).Value
    For I = 1 To UBound(Rng, 1)
        Dat = DateSerial(Year(Rng(I, 1)), Month(Rng(I, 1)), 1)
        Cot = Dic2.Item(Dat) + 1
        If Cot > TS Then TS = Cot
        If Dic1.Exists(Rng(I, 3)) Then
            Tem = Rng(I, 3): Dong = Dic1.Item(Tem)
            Arr(Dong, Cot) = Rng(I, 5)
        End If
    Next I
With Sheets("N-X XOP")
    .[E8:IV10000].ClearContents
    .[E8].Resize(K, TS + 1).Value = Arr
    .[E8].Resize(K, TS + 1).Value = .[E8].Resize(K, TS + 1).Value
End With
Set Dic1 = Nothing: Set Dic2 = Nothing: Set Ws = Nothing
MsgBox Timer - t
End Sub

 

[nguyen_sammi]

anh Ba Tê ơi, sao em copy dữ liệu vào, nó chỉ chạy tới row 848 là ngưng rồi hả anh? Dữ liệu của em còn rất nhiều

 

[nguyen_sammi]

anh ơi, code có chút vấn đề thì phải. Có vài chỗ bị sai nè. Em gửi lại file cho anh xem nhé, em có đánh dấu vào chỗ bị sai đó.
Anh sửa lại dùm em nha. huhu...

 

[Ba Tê]

anh ơi, code có chút vấn đề thì phải. Có vài chỗ bị sai nè. Em gửi lại file cho anh xem nhé, em có đánh dấu vào chỗ bị sai đó.
Anh sửa lại dùm em nha. huhu...

Dữ liệu mẫu ở trên, cột C là duy nhất, file sau một đống trùng "Không sử dụng xốp" (Cái này lúc đầu đâu có đâu?)
Như trên, lúc đầu mỗi ngày 1 mã hàng chỉ nhập xuất 1 lần, file sau thì nhiều lần, làm sao dự tính được?
Đưa file không giống thật thì người giúp cũng "điếc" là phải rồi.
Chép đè lại cái này lên cái cũ xem.

Public Sub GPE()
Dim Rng(), Dic1 As Object, Dic2 As Object, I As Long, J As Long, K As Long, Dat As Variant, t As Variant
Dim Arr(1 To 65000, 1 To 240), Cot As Long, Ws As Worksheet, Tem As Variant, Dong, TS As Long
t = Timer
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("N-X XOP")
    Rng = .Range(.[C8], .[C65000].End(xlUp)).Resize(, 3).Value
        For I = 1 To UBound(Rng, 1)
        K = I
            Tem = Rng(I, 1)
            If Not Dic1.Exists(Tem) Then
                Dic1.Add Tem, I
                Arr(I, 1) = Rng(I, 3)
                For J = 4 To 240 Step 3
                    Arr(I, J) = "=SUM(RC[-3]:RC[-2])-RC[-1]"
                Next J
            End If
        Next I
    Rng = .[F6:IV6].Value
        For I = 1 To UBound(Rng, 2)
            Tem = Rng(1, I)
            If Tem <> "" Then
                Cot = I + 1
                Dic2.Add Tem, Cot
            End If
        Next I
End With
Set Ws = Sheets("NHAN HANG XOP")
Rng = Ws.Range(Ws.[B11], Ws.[B65000].End(xlUp)).Resize(, 8).Value
    For I = 1 To UBound(Rng, 1)
        Dat = DateSerial(Year(Rng(I, 1)), Month(Rng(I, 1)), 1)
        Cot = Dic2.Item(Dat)
        If Cot > TS Then TS = Cot
        If Dic1.Exists(Rng(I, 6)) Then
            Tem = Rng(I, 6): Dong = Dic1.Item(Tem)
            Arr(Dong, Cot) = Arr(Dong, Cot) + Rng(I, 8)
        End If
    Next I
Set Ws = Sheets("XUAT HANG XOP")
Rng = Ws.Range(Ws.[A11], Ws.[A65000].End(xlUp)).Resize(, 5).Value
    For I = 1 To UBound(Rng, 1)
        Dat = DateSerial(Year(Rng(I, 1)), Month(Rng(I, 1)), 1)
        Cot = Dic2.Item(Dat) + 1
        If Cot > TS Then TS = Cot
        If Dic1.Exists(Rng(I, 3)) Then
            Tem = Rng(I, 3): Dong = Dic1.Item(Tem)
            Arr(Dong, Cot) = Arr(Dong, Cot) + Rng(I, 5)
        End If
    Next I
With Sheets("N-X XOP")
    .[E8:IV10000].ClearContents
    .[E8].Resize(K, TS + 1).Value = Arr
    .[E8].Resize(K, TS + 1).Value = .[E8].Resize(K, TS + 1).Value
End With
Set Dic1 = Nothing: Set Dic2 = Nothing: Set Ws = Nothing
MsgBox Timer - t
End Sub

 

[nguyen_sammi]

tại dữ liệu nhiều quá em xóa bớt cho khỏi nặng, vì up file excel lên chỉ cho có 97kb thôi à, hixhix... hok nghĩ nó bị vậy. Xin lỗi anh ba tê.