Xin nhờ cácc Anh/Chị ở diễn đàn giúp em tăng tốc code so sánh này với (1 người xem)

[thungdols]

Em có code so sánh tìm mảng trùng lặp như sau:

Sub MangTrung()
Dim Sh As Worksheet, Rng As Range, Clls As Range
Dim Rw As Integer, Col As Integer, Jj As Integer, Dem As Integer, MyColor As Byte
Dim Cll As Range, Rng1 As Range, Rng2 As Range, Rng11 As Range, Rng22 As Range
Dim Rnga As Range, Cllsa As Range
Dim Row As Integer, Ii As Integer, Kk As Integer

Sheets("B1").Select: Set Sh = Sheets("B2")
Sh.Cells.Interior.ColorIndex = 0: Cells.Interior.ColorIndex = 0
Rw = 3
Application.ScreenUpdating = False
Col = 100
Row = Sheet1.Cells(1, 1).CurrentRegion.Rows.Count - 1
For Ii = 1 To Row
Set Rng = Sheet1.Cells(Ii + 1, 1).Resize(, Col)
For Each Clls In Rng
With Application.WorksheetFunction
For Jj = 1 To Col
Set Rng1 = Clls.Resize(Rw, 3)
Set Rng2 = Sh.Cells(1, Jj).Resize(Rw, 3)
If .Sum(Rng1) = .Sum(Rng2) Then
Set Rnga = Sheet1.Cells(Ii + 1, Clls.Column).Resize(, 3)
For Each Cllsa In Rnga
For Kk = 0 To 2
Set Rng11 = Cllsa.Resize(Rw)
Set Rng22 = Sh.Cells(1, Jj + Kk).Resize(Rw)
If .Sum(Rng11) = .Sum(Rng22) Then
Dem = 0
For Each Cll In Rng11
Dem = Dem + 1
If Cll.Value <> Rng22.Cells(Dem, 1).Value Then Exit For
Next Cll
If Dem = Rw Then

MyColor = 34 + Clls.Column Mod 6
Rng1.Interior.ColorIndex = MyColor
Rng2.Interior.ColorIndex = MyColor

End If
End If
Next Kk
Next Cllsa
End If
Next Jj
End With

Next Clls
Next Ii
End Sub
nhưng code chạy chậm quá. nửa ngày trời mới rà soát được có 3500 dòng @@. Em sài đồ cổ excell 2003. .
Mong các chú/bác các anh/chị trong diễn đàn giúp em nhanh nhanh nhé. em cám ơn

 

[giola]

1) bạn nên đặt code của mình vào trong tag CODE của diễn đàn cho nó dễ nhìn

2) nên upload file lên và giải thích nhiệm vụ CODe của bạn là làm gì, kết quả mong muốn, thì mới rút ngắn thời gian được,

3) code bạn chậm là cái chắc vì quá nhiều vòng lặp FOR lồng nhau, lại dùng ham SUM của worksheetfunction...