Xóa dòng trùng với điều kiện (VBA) (Dòng không trùng 100%)

[MinhKhai]

Sau khi tìm kiếm mà không có bài nào giống yêu cầu này nên em xin đăng bài mới để các anh chị em nhờ giúp đỡ
Như tiêu đề, em nhờ mọi người viết code (hoặc không cần code mà xử lý được cũng tốt) để xóa các dòng bị trùng. Thực ra nó không phải trùng tất cả các cột (nếu trùng 100% thì Excel tự có công cụ xử lý rồi).
File của em được kết xuất từ phần mềm, em muốn xóa các dòng có nội dung trùng nhau trong 4 cột A; G; H; J (4 cột tô nền xanh như file đính kèm), Khi dòng có 4 ô thuộc 4 cột nói trên bị trùng thì sẽ xóa dòng mà có ô thuộc cột I (tô màu hồng) có giá trị nhỏ hơn.

Tóm tắt yêu cầu: Xóa dòng trùng
- Thế nào là dòng trùng: Là dòng có 4 ô thuộc cột màu xanh có giá trị giống nhau
- Khi xác định trùng, xóa dòng nào: Trong các ô trùng dòng, xóa dòng mà ô màu hồng có giá trị nhỏ hơn

Em xin cảm ơn sự giúp đỡ !

 

[snow25]

Sau khi tìm kiếm mà không có bài nào giống yêu cầu này nên em xin đăng bài mới để các anh chị em nhờ giúp đỡ
Như tiêu đề, em nhờ mọi người viết code (hoặc không cần code mà xử lý được cũng tốt) để xóa các dòng bị trùng. Thực ra nó không phải trùng tất cả các cột (nếu trùng 100% thì Excel tự có công cụ xử lý rồi).
File của em được kết xuất từ phần mềm, em muốn xóa các dòng có nội dung trùng nhau trong 4 cột A; G; H; J (4 cột tô nền xanh như file đính kèm), Khi dòng có 4 ô thuộc 4 cột nói trên bị trùng thì sẽ xóa dòng mà có ô thuộc cột I (tô màu hồng) có giá trị nhỏ hơn.

Tóm tắt yêu cầu: Xóa dòng trùng
- Thế nào là dòng trùng: Là dòng có 4 ô thuộc cột màu xanh có giá trị giống nhau
- Khi xác định trùng, xóa dòng nào: Trong các ô trùng dòng, xóa dòng mà ô màu hồng có giá trị nhỏ hơn

Em xin cảm ơn sự giúp đỡ !

Đây bạn xem.

Sub xoadong()
Dim arr, arr1
Dim dic As Object
Dim a As Long, b As Long, c As Long, i As Long, j As Long, d As Long
Dim dk As String
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     b = .Range("A" & Rows.Count).End(xlUp).Row
     arr = .Range("a1:N" & b).Value
     ReDim arr1(1 To UBound(arr, 1), 1 To 14)
     For i = 1 To UBound(arr, 1)
     dk = arr(i, 1) & "#" & arr(i, 7) & "#" & arr(i, 8) & "#" & arr(i, 10)
         If dic.exists(dk) = 0 Then
         a = a + 1
         For j = 1 To 14
             arr1(a, j) = arr(i, j)
         Next j
         dic.Item(dk) = Array(a)
         Else
             c = dic.Item(dk)(0)
             If CLng(arr1(c, 9)) < CLng(arr(i, 9)) Then
                 For j = 1 To 14
                     arr1(c, j) = arr(i, j)
                 Next j
             End If
          End If
      Next i
End With
With Sheet2
     d = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("a1:a" & d).Resize(, 14).ClearContents
     If a Then .Range("a1").Resize(a, 14).Value = arr1
End With

 

[MinhKhai]

Đây bạn xem.

Sub xoadong()
Dim arr, arr1
Dim dic As Object
Dim a As Long, b As Long, c As Long, i As Long, j As Long, d As Long
Dim dk As String
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     b = .Range("A" & Rows.Count).End(xlUp).Row
     arr = .Range("a1:N" & b).Value
     ReDim arr1(1 To UBound(arr, 1), 1 To 14)
     For i = 1 To UBound(arr, 1)
     dk = arr(i, 1) & "#" & arr(i, 7) & "#" & arr(i, 8) & "#" & arr(i, 10)
         If dic.exists(dk) = 0 Then
         a = a + 1
         For j = 1 To 14
             arr1(a, j) = arr(i, j)
         Next j
         dic.Item(dk) = Array(a)
         Else
             c = dic.Item(dk)(0)
             If CLng(arr1(c, 9)) < CLng(arr(i, 9)) Then
                 For j = 1 To 14
                     arr1(c, j) = arr(i, j)
                 Next j
             End If
          End If
      Next i
End With
With Sheet2
     d = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("a1:a" & d).Resize(, 14).ClearContents
     If a Then .Range("a1").Resize(a, 14).Value = arr1
End With

Em đã test, code của bác chạy nhanh và đúng như ý.
Em cảm ơn bác.

Em sẽ Save as code thành Add-In để dùng hàng ngày. Rất mong bác bổ sung sao cho nó tổng quát như:
1. Thêm code tạo sheet và đưa kết quả vào sheet này.
2. Nếu các cột điều kiện thay đổi vị trí thì code vẫn chạy chính xác.

Xin chân thành cảm ơn

 

[MinhKhai]

Đây bạn xem.

Sub xoadong()
Dim arr, arr1
Dim dic As Object
Dim a As Long, b As Long, c As Long, i As Long, j As Long, d As Long
Dim dk As String
Set dic = CreateObject("scripting.dictionary")
With Sheet1
     b = .Range("A" & Rows.Count).End(xlUp).Row
     arr = .Range("a1:N" & b).Value
     ReDim arr1(1 To UBound(arr, 1), 1 To 14)
     For i = 1 To UBound(arr, 1)
     dk = arr(i, 1) & "#" & arr(i, 7) & "#" & arr(i, 8) & "#" & arr(i, 10)
         If dic.exists(dk) = 0 Then
         a = a + 1
         For j = 1 To 14
             arr1(a, j) = arr(i, j)
         Next j
         dic.Item(dk) = Array(a)
         Else
             c = dic.Item(dk)(0)
             If CLng(arr1(c, 9)) < CLng(arr(i, 9)) Then
                 For j = 1 To 14
                     arr1(c, j) = arr(i, j)
                 Next j
             End If
          End If
      Next i
End With
With Sheet2
     d = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("a1:a" & d).Resize(, 14).ClearContents
     If a Then .Range("a1").Resize(a, 14).Value = arr1
End With

Chào anh. Cảm ơn anh đã giúp code trên
Sau khi chạy 1 thời gian, theo yêu cầu công việc, em có nhu cầu lọc như yêu cầu ở #1 nhưng giữ lại dòng mà ô được tô màu hồng có giá trị nhỏ hơn (bỏ dòng mà ô thuộc cột màu hồng có giá trị lớn hơn).
Em đã thử chỉnh code nhưng không lần nào thành công
Mong bác @snow25 hoặc các anh chị nào biết sửa giúp

 

[snow25]

Chào anh. Cảm ơn anh đã giúp code trên
Sau khi chạy 1 thời gian, theo yêu cầu công việc, em có nhu cầu lọc như yêu cầu ở #1 nhưng giữ lại dòng mà ô được tô màu hồng có giá trị nhỏ hơn (bỏ dòng mà ô thuộc cột màu hồng có giá trị lớn hơn).
Em đã thử chỉnh code nhưng không lần nào thành công
Mong bác @snow25 hoặc các anh chị nào biết sửa giúp

Bạn tìm trong code cái dấu nhỏ hơn giờ thành lớn hơn là được nhé.

 

[MinhKhai]

Bạn tìm trong code cái dấu nhỏ hơn giờ thành lớn hơn là được nhé.

Xin cảm ơn anh