Xin giúp đỡ chỉnh code VBA

[happyghost2000]

Các bác ơi ! giúp em chỉnh code dùm.
Em có đoạn code bên dưới . Em muốn dùm mãng để hứng kết quả & hiện thị thay thế cho Cells( i, .....)
Vì dùng cells code chạy chậm quá à.
Mong các bác giúp em .
--------------

Sub tinhthieu()
Dim i As Long, lr As Long
Dim Tong1 As Long, Tong2&, Tong3&
Dim Arr()

Sheet12.Range("P4:R100000").ClearContents
lr = Sheet12.Range("A10000").End(xlUp).row
Arr = Sheet12.Range("A4:S" & lr).Value
'redim Tong1 = Sheet12.Range("U4:U" & lr).Value


For i = 1 To UBound(Arr, 1)
If Arr(i, 13) - Arr(i, 12) - Arr(i, 10) > 0 Then
Cells(i + 3, 16) = Arr(i, 13) - Arr(i, 12) - Arr(i, 10)
End If
If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Cells(i + 3, 16) > 0 Then
Cells(i + 3, 17) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Cells(i + 3, 16)
End If
If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Cells(i + 3, 17) > 0 Then
Cells(i + 3, 18) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Cells(i + 3, 17)
End If

Next i
'Sheet12.Range("u4:w100000").ClearContents
'Sheet12.Range("U4:U" & lr).Resize = Tong1
'Sheet12.Range("V4:V" & lr).Resize = Tong2
'Sheet12.Range("W4:W" & lr).Resize = Tong3

End Sub

 

[SA_DQ]

Bạn tham khảo con ni xem sao:

Sub TinhtHieu()
 Dim i As Long, lR As Long
 Dim Tmr As Double, Tong16 As Double, Tong17 As Double, Tong18 As Double
 Dim Arr()

9 Sheet12.Range("P4:R100000").ClearContents '???    '
 Tmr = Timer()
 lR = Sheet12.Range("A10000").End(xlUp).Row
 ReDim aKQ(1 To lR, 1 To 3)
 Arr = Sheet12.Range("A4:S" & lR).Value

For i = 1 To UBound(Arr, 1)
    If Arr(i, 13) - Arr(i, 12) - Arr(i, 10) > 0 Then
        Tong16 = Arr(i, 13) - Arr(i, 12) - Arr(i, 10)
1       ' Cells(i + 3, 16) = Arr(i, 13) - Arr(i, 12) - Arr(i, 10) '
        aKQ(i, 1) = Tong16
    End If
    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Tong16 > 0 Then
'    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Cells(i + 3, 16) > 0 Then    '
        Tong17 = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Tong16
2 '        Cells(i + 3, 17) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Cells(i + 3, 16)
        aKQ(i, 2) = Tong17
    End If
    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Tong17 > 0 Then
'    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Cells(i + 3, 17) > 0 Then
3         Tong18 = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Tong16 - Tong17
'        Cells(i + 3, 18) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Cells(i + 3, 17)'
        aKQ(i, 3) = Tong18
    End If
Next i
[P4].Resize(i, 3).Value = aKQ():                    MsgBox Timer() - Tmr
End Sub

 

[VetMini]

Arr(i, 10) + Arr(i, 12) - Arr(i, 13) là một biểu thức được tính đến mấy lần !!!

 

[happyghost2000]

Bạn tham khảo con ni xem sao:

Sub TinhtHieu()
 Dim i As Long, lR As Long
 Dim Tmr As Double, Tong16 As Double, Tong17 As Double, Tong18 As Double
 Dim Arr()

9 Sheet12.Range("P4:R100000").ClearContents '???    '
 Tmr = Timer()
 lR = Sheet12.Range("A10000").End(xlUp).Row
 ReDim aKQ(1 To lR, 1 To 3)
 Arr = Sheet12.Range("A4:S" & lR).Value

For i = 1 To UBound(Arr, 1)
    If Arr(i, 13) - Arr(i, 12) - Arr(i, 10) > 0 Then
        Tong16 = Arr(i, 13) - Arr(i, 12) - Arr(i, 10)
1       ' Cells(i + 3, 16) = Arr(i, 13) - Arr(i, 12) - Arr(i, 10) '
        aKQ(i, 1) = Tong16
    End If
    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Tong16 > 0 Then
'    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Cells(i + 3, 16) > 0 Then    '
        Tong17 = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Tong16
2 '        Cells(i + 3, 17) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - Cells(i + 3, 16)
        aKQ(i, 2) = Tong17
    End If
    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Tong17 > 0 Then
'    If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Cells(i + 3, 17) > 0 Then
3         Tong18 = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Tong16 - Tong17
'        Cells(i + 3, 18) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - Cells(i + 3, 16) - Cells(i + 3, 17)'
        aKQ(i, 3) = Tong18
    End If
Next i
[P4].Resize(i, 3).Value = aKQ():                    MsgBox Timer() - Tmr
End Sub

Em cám ơn Bác Nhiều . Code chạy rất nhanh. Nhưng có 1 số kết quả không chính xác , để em tìm hiểu thêm. Nếu không tìm ra, em sẽ chạy lên xin giúp đỡ tiếp. Một lần nữa cám ơn bác

 

[Hoàng Trọng Nghĩa]

Em cám ơn Bác Nhiều . Code chạy rất nhanh. Nhưng có 1 số kết quả không chính xác , để em tìm hiểu thêm. Nếu không tìm ra, em sẽ chạy lên xin giúp đỡ tiếp. Một lần nữa cám ơn bác

Lẽ ra bạn nên đưa file lên, người hướng dẫn sẽ biết cách chỉnh lại các vấn đề lỗi.

 

[SA_DQ]

Lẽ ra bạn nên đưa file lên, người hướng dẫn sẽ biết cách chỉnh lại các vấn đề lỗi.

Còn hổng có file thì làm thầy bói đoán chân voi cũng OK mà!

 

[happyghost2000]

Dạ em biết sai rồi . Em xin bổ sung file đính kèm .
Cột P~R : dùng code Cells
Cột S~U : dùng code mãng bác SA_DQ .
Khi em so kết quả có sự sai biệt ạ .
Mong các bác giúp em ạ . @SA_DQ , @Hoàng Trọng Nghĩa

 

[happyghost2000]

Em đã chỉnh lại như sau & kết quả đã ra đúng !!!!.

-----------------


Sub TinhtHieu_Mang3()
Dim i As Long, lR As Long
Dim Tmr As Double
Dim Tong16(), Tong17(), Tong18()

Dim Arr()

Sheet12.Range("S4:U100000").ClearContents '??? '
Tmr = Timer()
lR = Sheet12.Range("A10000").End(xlUp).Row
ReDim aKQ(1 To lR, 1 To 3)
ReDim kq1(1 To 10000, 1 To 1)
ReDim kq2(1 To 10000, 1 To 1)
ReDim kq3(1 To 10000, 1 To 1)



Arr = Sheet12.Range("A4:R" & lR).Value

For i = 1 To UBound(Arr, 1)
If Arr(i, 13) - Arr(i, 12) - Arr(i, 10) > 0 Then
kq1(i, 1) = Arr(i, 13) - Arr(i, 12) - Arr(i, 10)
'kq1(i, 1) = Tong16
End If

If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - kq1(i, 1) > 0 Then
kq2(i, 1) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14)) - kq1(i, 1)
'kq2(i, 2) = Tong17
End If

If -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - kq1(i, 1) - kq2(i, 1) > 0 Then
kq3(i, 1) = -(Arr(i, 10) + Arr(i, 12) - Arr(i, 13) - Arr(i, 14) - Arr(i, 15)) - kq1(i, 1) - kq2(i, 1)
'kq3(i, 3) = Tong18
End If

Next i
[S4].Resize(i, 1).Value = kq1()
[T4].Resize(i, 1).Value = kq2()
[U4].Resize(i, 1).Value = kq3()
MsgBox Timer() - Tmr

End Sub

 

[happyghost2000]

Em Chân Thành cảm ơn bác @SA_DQ , đã giúp đỡ em .

 

[bebo021999]

Làm đại, trật làm lại.

Sub TinhtHieu_Cell()
Dim i&, lr&, T1 As Double, T2 As Double, T3 As Double
Dim arr
lr = Sheet12.Cells(Rows.Count, "J").End(xlUp).Row
arr = Sheet12.Range("J4:R" & lr).Value
For i = 1 To UBound(arr)
    T1 = arr(i, 1) + arr(i, 3) - arr(i, 4)
    T2 = T1 - arr(i, 5)
    T3 = T2 - arr(i, 6)
    If T1 < 0 Then arr(i, 7) = -T1
    If T2 < 0 Then arr(i, 8) = -T2 - arr(i, 7)
    If T3 < 0 Then arr(i, 9) = -T3 - arr(i, 7) - arr(i, 8)
Next
Sheet12.Range("P4:R100000").ClearContents
Sheet12.Range("J4").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

 

[happyghost2000]

Làm đại, trật làm lại.

Sub TinhtHieu_Cell()
Dim i&, lr&, T1 As Double, T2 As Double, T3 As Double
Dim arr
lr = Sheet12.Cells(Rows.Count, "J").End(xlUp).Row
arr = Sheet12.Range("J4:R" & lr).Value
For i = 1 To UBound(arr)
    T1 = arr(i, 1) + arr(i, 3) - arr(i, 4)
    T2 = T1 - arr(i, 5)
    T3 = T2 - arr(i, 6)
    If T1 < 0 Then arr(i, 7) = -T1
    If T2 < 0 Then arr(i, 8) = -T2 - arr(i, 7)
    If T3 < 0 Then arr(i, 9) = -T3 - arr(i, 7) - arr(i, 8)
Next
Sheet12.Range("P4:R100000").ClearContents
Sheet12.Range("J4").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

Code bác hay quá trời luôn. Em học được thêm thuật toán tuyệt vời Ông mặt trời.
Cám ơn bác nhiều lắm.

Chân thành cảm ơn 2 bác @bebo021999 & bác @SA_DQ

Bài đã được tự động gộp: 22/7/22

Sheet12.Range("J4").Resize(UBound(arr), UBound(arr, 2)).Value = arr

Bác dịch dùm em câu lệnh này giúp. Em chưa hiểu ạ. Em thấy hay quá mà không hiểu, .Mong bác giúp em .