Xoá dòng trùng nhau trong Excel bằng VBA

LEHOC đã viết:

Xin chào các anh/chị.
Em có file có khoảng 12k dòng được sắp xếp để dồn các dòng trùng nhau, em tự code để xoá các dòng trùng này bằng Do...While nhưng thời gian xử lý "Running" lâu quá.
Nhờ a/c chỉ giáo ạ.
Em cảm ơn!

PHP:Sao chép.

Sub DelDupRows()
    Dim i, Rng
    i = 4
    Do
        If Cells(i, "C").Value = Cells(i + 1, "C").Value Then
            If Cells(i, "F").Value = Cells(i + 1, "F").Value Then
                Rows(i + 1).Delete
                i = i - 1
            End If
        End If
        i = i + 1
    Loop While Cells(i + 1, "C").Value <> ""
End Sub

Nhấp chuột vào đây để mở rộng...

Sub linhtinh()
    Dim arr, i As Long, lr As Long, kq, a As Long, dic As Object, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("a2:d" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 4)
         For i = 1 To UBound(arr)
             dk = arr(i, 2) & "#" & arr(i, 3)
             If Not dic.exists(dk) Then
                dic.Add dk, a
                a = a + 1
                kq(a, 1) = a
                kq(a, 2) = arr(i, 2)
                kq(a, 3) = arr(i, 3)
                kq(a, 4) = arr(i, 4)
             End If
        Next i
        .Range("a2:d" & lr).ClearContents
        If a Then .Range("a2:d2").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

LEHOC đã viết:

Xin chào các anh/chị.
Em có file có khoảng 12k dòng được sắp xếp để dồn các dòng trùng nhau, em tự code để xoá các dòng trùng này bằng Do...While nhưng thời gian xử lý "Running" lâu quá.
Nhờ a/c chỉ giáo ạ.
Em cảm ơn!

PHP:Sao chép.

Sub DelDupRows()
    Dim i, Rng
    i = 4
    Do
        If Cells(i, "C").Value = Cells(i + 1, "C").Value Then
            If Cells(i, "F").Value = Cells(i + 1, "F").Value Then
                Rows(i + 1).Delete
                i = i - 1
            End If
        End If
        i = i + 1
    Loop While Cells(i + 1, "C").Value <> ""
End Sub

Nhấp chuột vào đây để mở rộng...