Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính (2 người xem)

[A HOANG 620]

Em cần làm bảng dò giá gốc và giá công bố từ sheet Dulieu, tính giá thành và kết quả. Em làm bằng công thức nhưng dò dữ liệu lớn 2000 dòng nên chạy hơi giật. anh chị chú bác giúp em viết code vba thay công thức để chạy nhẹ hơn. em cám ơn

 

[HUONGHCKT]

Em cần làm bảng dò giá gốc và giá công bố từ sheet Dulieu, tính giá thành và kết quả. Em làm bằng công thức nhưng dò dữ liệu lớn 2000 dòng nên chạy hơi giật. anh chị chú bác giúp em viết code vba thay công thức để chạy nhẹ hơn. em cám ơn

Trong khi chờ code khác thử Tham khảo đoạn code nông dân sau.
(làm theo ý hiểu và dữ liệu trên file đính kèm)

Sub TimZa()
Dim i&, j&, Lr&, t&, Rng As Range
Dim Arr(), KQ()
Dim dic As Object, key
With Sheets("Dulieu")
Lr = .Range("B100000").End(xlUp).Row
Arr = .Range("B2:D" & Lr).Value
End With
Set dic = CreateObject("Scripting.dictionary")
For i = 1 To UBound(Arr)
    If Arr(1, 1) <> Empty Then
        key = Arr(i, 1)
        If Not dic.exists(key) Then dic.Add (key), i
    End If
Next i

With Sheets("DG")
Set Rng = .Range("F6:G" & .Range("B100000").End(xlUp).Row)
ReDim KQ(1 To Rng.Rows.Count, 1 To 3)
For i = 1 To Rng.Rows.Count
    t = t + 1
    If Rng(1, 1) <> Empty Then
        key = Rng(i, 1)
        If dic.exists(key) Then
            j = dic.Item(key)
            KQ(t, 1) = Arr(j, 2) + Rng(i, 2)
            KQ(t, 2) = Arr(j, 3)
            If KQ(t, 1) = KQ(t, 2) Then KQ(t, 3) = "Hoàn v?n"
            If KQ(t, 1) > KQ(t, 2) Then KQ(t, 3) = "L?i"
            If KQ(t, 1) < KQ(t, 2) Then KQ(t, 3) = "L?"
        End If
    End If
Next i
.Range("H6").Resize(t, 3) = KQ
Set dic = Nothing
MsgBox "Xong r?i!"
End With
End Sub

 

[A HOANG 620]

Trong khi chờ code khác thử Tham khảo đoạn code nông dân sau.
(làm theo ý hiểu và dữ liệu trên file đính kèm)

Sub TimZa()
Dim i&, j&, Lr&, t&, Rng As Range
Dim Arr(), KQ()
Dim dic As Object, key
With Sheets("Dulieu")
Lr = .Range("B100000").End(xlUp).Row
Arr = .Range("B2:D" & Lr).Value
End With
Set dic = CreateObject("Scripting.dictionary")
For i = 1 To UBound(Arr)
    If Arr(1, 1) <> Empty Then
        key = Arr(i, 1)
        If Not dic.exists(key) Then dic.Add (key), i
    End If
Next i

With Sheets("DG")
Set Rng = .Range("F6:G" & .Range("B100000").End(xlUp).Row)
ReDim KQ(1 To Rng.Rows.Count, 1 To 3)
For i = 1 To Rng.Rows.Count
    t = t + 1
    If Rng(1, 1) <> Empty Then
        key = Rng(i, 1)
        If dic.exists(key) Then
            j = dic.Item(key)
            KQ(t, 1) = Arr(j, 2) + Rng(i, 2)
            KQ(t, 2) = Arr(j, 3)
            If KQ(t, 1) = KQ(t, 2) Then KQ(t, 3) = "Hoàn v?n"
            If KQ(t, 1) > KQ(t, 2) Then KQ(t, 3) = "L?i"
            If KQ(t, 1) < KQ(t, 2) Then KQ(t, 3) = "L?"
        End If
    End If
Next i
.Range("H6").Resize(t, 3) = KQ
Set dic = Nothing
MsgBox "Xong r?i!"
End With
End Sub

dạ cám ơn bác nhiều