[VBA] cần tối ưu hóa tốc độ file - cong thức for ... next

[thuan2210]

Dear A/c !
Em muốn nhờ các a/c tối ưu hóa giúp em code ở sheet DATANEW
Sheet này hiện đang dung 2 vòng lặp long nhau để tính sumif nhưng tốc độ rất chậm và nặng.
Rất mong các a/c xem qua và hướng dẫn giúp em cách xữ lý ạ.

 

[snow25]

Dear A/c !
Em muốn nhờ các a/c tối ưu hóa giúp em code ở sheet DATANEW
Sheet này hiện đang dung 2 vòng lặp long nhau để tính sumif nhưng tốc độ rất chậm và nặng.
Rất mong các a/c xem qua và hướng dẫn giúp em cách xữ lý ạ.

Sửa chút code của bạn xem đúng không nhé.

Sub linhtinh()
    Dim i, y, Vung, Ws, dic As Object
    Dim A, HOLDING As Integer
    Set Ws = Sheets("INPUT")
    Vung = Ws.Range(Ws.[A2], Ws.[A30000].End(xlUp)).Resize(, 19)
    Set dic = CreateObject("scripting.dictionary")
    Sheets("DATANEW").Select
    Range("F2:G5000").Select
    Selection.ClearContents
     With Sheets("DATANEW")
                lastrow = .Range("A" & Rows.Count).End(xlUp).Row
                If lastrow < 3 Then Exit Sub
                .Range("F2:G" & lastrow).ClearContents
                arr = .Range("A2:G" & lastrow).Value
                For i = 2 To UBound(arr)
                    dk = arr(i, 3) & arr(i, 4) & .Range("j1").Value
                    dic.Item(dk) = i
                Next i
                For i = 1 To UBound(Vung)
                   dk = Vung(i, 3) & Vung(i, 6) & Vung(i, 1)
                   b = dic.Item(dk)
                   If b Then
                      arr(b, 6) = arr(b, 6) + Vung(i, 8)
                      arr(b, 7) = arr(b, 7) + 1
                   End If
                Next i
                .Range("A2:G" & lastrow).Value = arr
    End With
End Sub