Xóa dòng trùng.

[DMQ]

Chào các anh chị trong GPE!!!!
Em có file này nhờ các anh chị viết code xóa dòng trùng ạ.
Trong file nếu cột D, cột F, cột H trùng nhau thì xóa dòng trùng, chỉ chừa lại dòng trên cùng của dòng trùng ạ.
Em có ví dụ trong file ạ.
Em xin gửi file, file em có cỡ 3000 dòng ạ.
Em chỉ làm mẫu 4 trường hợp trùng thôi ạ.
mong các anh chị giúp đỡ.

 

[vanthinh3101]

Chào các anh chị trong GPE!!!!
Em có file này nhờ các anh chị viết code xóa dòng trùng ạ.
Trong file nếu cột D, cột F, cột H trùng nhau thì xóa dòng trùng, chỉ chừa lại dòng trên cùng của dòng trùng ạ.
Em có ví dụ trong file ạ.
Em xin gửi file, file em có cỡ 3000 dòng ạ.
Em chỉ làm mẫu 4 trường hợp trùng thôi ạ.
mong các anh chị giúp đỡ.

Bạn tham khảo code bên dưới.
Tôi tự đưa thêm 1 điều kiện là dòng nào cả 3 cột D, F, H cùng trống thì không lấy.

Sub RemoveDuplicateRows()
    Dim sArr(), Res()
    Dim lR As Long, I As Long, J As Long, K As Long
    Dim Dic As Object
    Dim Key As String
    Dim Header As Range
    
    'Dong tieu de
    Set Header = Sheet1.Range("A5:J5")
    'Dong cuoi co du lieu
    lR = Sheet1.Range("D" & Rows.Count).End(xlUp).Row
    'Mang 2 chieu chua toan bo du lieu goc
    sArr = Sheet1.Range("A5:J" & lR).Value
    'Xac dinh kich thuoc mang 2 chieu chua ket qua
    ReDim Res(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    
    'Khai bao thu vien Scripting.Dictionary
    Set Dic = CreateObject("Scripting.Dictionary")
    
    'Tao vong lap qua tung dong cua sArr
    For I = 2 To UBound(sArr, 1)
        'Key ghep cot D, F, H
        Key = sArr(I, 4) & "|" & sArr(I, 6) & "|" & sArr(I, 8)
        'Kiem tra Key da ton tai trong Dic chua?
        If Len(Replace(Key, "|", "")) And Not Dic.exists(Key) Then
            'Gan Key vao Dic
            Dic.Add Key, ""
            'Thiet lap gia tri K
            K = K + 1
            'Tao vong lap qua tung cot cua sArr tuong ung tung dong
            For J = 1 To UBound(sArr, 2)
                Res(K, J) = sArr(I, J)
            Next J
        End If
    Next I
    
    'Dien ket qua ra vi tri moi
    'Dong Header
    Header.Copy Sheet1.Range("T5")
    'Du lieu sau khi loai trung
    Sheet1.Range("T6").Resize(K, UBound(Res, 2)) = Res
    
    'Giai phong bo nho
    Set Header = Nothing: Set Dic = Nothing
    
    'Thong bao ket qua
    MsgBox "Done", vbInformation, "Daily Excel"
    
End Sub

Lâu không viết ngượng tay quá

 

[HUONGHCKT]

Chào các anh chị trong GPE!!!!
Em có file này nhờ các anh chị viết code xóa dòng trùng ạ.
Trong file nếu cột D, cột F, cột H trùng nhau thì xóa dòng trùng, chỉ chừa lại dòng trên cùng của dòng trùng ạ.
Em có ví dụ trong file ạ.
Em xin gửi file, file em có cỡ 3000 dòng ạ.
Em chỉ làm mẫu 4 trường hợp trùng thôi ạ.
mong các anh chị giúp đỡ.

Có nhất khoát phải dùng code không khi có thể làm thủ công được:
Cách làm:
1/ Dùng 1 cột phụ: ví dụ cột L và nhập vào L6=COUNTIFS($D$6:$D6;$D6;$F$6:$F6;$F6;$H$6:$H6;$H6), copy cho các ô còn lại của cột L.
2/Lọc theo ĐK cột L với các tiêu chí khác 1 (0,2,3,...)
3/Bôi đen các dòng đó và xóa (phải chuột chọn delete Row)
kết quả thu được là các dòng có cột L =1 được xếp liền nhau không ngắt quãng.

 

[DMQ]

Cám ơn bạn @vanthinh3101 nhiều, mong bạn xóa dòng dùm,không chép qua T5.
Cám ơn anh @HUONGHCKT nhiều, sao em dùng công thức của anh, không trùng cũng ra số 2 ạ.

 

[thien-16]

Chào các anh chị trong GPE!!!! Em có file này nhờ các anh chị viết code xóa dòng trùng ạ. Trong file nếu cột D, cột F, cột H trùng nhau thì xóa dòng trùng, chỉ chừa lại dòng trên cùng của dòng trùng ạ. Em có ví dụ trong file ạ. Em xin gửi file, file em có cỡ 3000 dòng ạ. Em chỉ làm mẫu 4 trường hợp trùng thôi ạ. mong các anh chị giúp đỡ.

Chào các anh chị trong GPE!!!!
Em có file này nhờ các anh chị viết code xóa dòng trùng ạ.
Trong file nếu cột D, cột F, cột H trùng nhau thì xóa dòng trùng, chỉ chừa lại dòng trên cùng của dòng trùng ạ.
Em có ví dụ trong file ạ.
Em xin gửi file, file em có cỡ 3000 dòng ạ.
Em chỉ làm mẫu 4 trường hợp trùng thôi ạ.
mong các anh chị giúp đỡ.

Xem thử file này ok không nha

 

[HUONGHCKT]

Cám ơn anh @HUONGHCKT nhiều, sao em dùng công thức của anh, không trùng cũng ra số 2 ạ.

Bạn kiểm tra lại chứ chả lẽ ngài Bill lại cho ra 1 sản phẩm sai?!?
Trong hàm Countifs(...) nó sẽ lấy từ dòng đầu tiên đến dòng hiện tại để đếm với điệu kiện là dòng hiện tại. Điều kiện ở đây là 3 phần tử của 3 cột tương ứng, cho nên khả năng trùng là không cao.

 

[DMQ]

Bạn @thien-16 file bạn có gì đâu bạn, vẫn là file gốc mà.
Mong anh @HUONGHCKT xem file bài #4 ạ, các dòng em bôi vàng dó ạ.

 

[huuthang_bd]

Mong anh @HUONGHCKT xem file bài #4 ạ, các dòng em bôi vàng dó ạ.

Chỉ kiểm tra có trùng hay không mà bạn cũng không kiểm tra được sao.

 

[HUONGHCKT]

Mong anh @HUONGHCKT xem file bài #4 ạ, các dòng em bôi vàng dó ạ.

Bạn không biết cách kiểm tra hay là sao hả trời?
xem hình :
tôi chỉ lấy 1 ví dụ mã ĐH(cột C) = 3278, YC(cột F) =02 :
dòng tô đỏ và dòng tô màu vàng bạn xem nó có giống nhau không?
Tự rút ra kết luận

 

[DMQ]

Anh @huuthang_bd, như anh @HUONGHCKT nói thì lọc cột L theo điều kiện khác 1 rồi xóa dòng, thì sẽ xóa luôn các dòng không trùng ạ.Các dòng trong file bài 4 em bôi vàng đó chỉ trùng cột D và cột F còn cột H có trùng đâu mà cột L là số 2.Nên khi lọc cột L lấy 0,2,3..vvv rồi xóa dòng thì xóa các dòng vàng đó rôi, mà nó có trùng đâu.

 

[huuthang_bd]

Anh @huuthang_bd, như anh @HUONGHCKT nói thì lọc cột L theo điều kiện khác 1 rồi xóa dòng, thì sẽ xóa luôn các dòng không trùng ạ.Các dòng trong file bài 4 em bôi vàng đó chỉ trùng cột D và cột F còn cột H có trùng đâu mà cột L là số 2.Nên khi lọc cột L lấy 0,2,3..vvv rồi xóa dòng thì xóa các dòng vàng đó rôi, mà nó có trùng đâu.

Sao bạn cứ khăng khăng như vậy mà không chịu kiểm tra lại nhỉ. Các dòng bạn bôi vàng đều có dòng trùng với nó ở bên trên.

 

[DMQ]

Thành thật xin lỗi anh @HUONGHCKT và anh @huuthang_bd ạ.
Lỗi tại em không kiểm tra kỹ ạ.

 

[DMQ]

Các anh chị giúp em code xóa dòng trùng với ạ.

 

[thien-16]

Bạn @thien-16 file bạn có gì đâu bạn, vẫn là file gốc mà.
Mong anh @HUONGHCKT xem file bài #4 ạ, các dòng em bôi vàng dó ạ.

Xin lỗi nha!
Check lại file này thử

 

[HUONGHCKT]

Các anh chị giúp em code xóa dòng trùng với ạ.

Tại sao bạn lại không dùng hàm và lọc của Mr.Bill nhỉ: Đơn giản, dễ làm, và chính xác
Còn muốn code thì Bạn tham khảo code củ chuối sau.
Hi vọng bạn có thêm nhiều tùy biến để linh hoạt hơn

Sub XoaDong()
    Dim Rng As Range
    Dim Lr&, i&, k&
    Dim Dic As Object
    Dim Key As String

    With Sheet2
    Lr = .Range("D" & Rows.Count).End(xlUp).Row
If Lr <= 5 Then Exit Sub
    Set Dic = CreateObject("Scripting.Dictionary")
    
    For i = 6 To Lr
        If .Range("D" & i) = Empty And .Range("F" & i) = Empty And .Range("H" & i) = Empty Then
            GoTo Run1
        Else
            Key = .Range("D" & i) & "|" & .Range("F" & i) & "|" & .Range("H" & i)
            If Not Dic.exists(Key) Then
                k = k + 1:  Dic.Add Key, k
                GoTo Run
            Else
                GoTo Run1
            End If
        End If
Run1:
            If Rng Is Nothing Then
                Set Rng = Rows(i)
            Else
                Set Rng = Union(Rng, Rows(i))
            End If
Run:
Next i
If Not Rng Is Nothing Then
    Rng.Select
    Selection.Delete Shift:=xlUp
End If
End With
Set Dic = Nothing
    MsgBox "Done", vbInformation, "Daily Excel"
End Sub

 

[SA_DQ]

Lâu lâu cũng phải "văn ôn võ . . ." 1 lần

Sub XoaDongTrungDe1()
 Dim Arr(), Dic As Object
 Dim J As Long, Rws As Long, W As Integer, Col As Integer, Cot As Integer
 Dim Key As String

 With Sheet2
    Rws = .UsedRange.Rows.Count:       Col = .UsedRange.Columns.Count
    Set Dic = CreateObject("Scripting.Dictionary")
    Arr() = [A6].Resize(Rws, Col).Value
    ReDim aKQ(1 To Rws, 1 To Col)
    For J = 1 To UBound(Arr())
        Key = Arr(J, 4) & "@" & Arr(J, 6) & "|" & Arr(J, 8)
        If Len(Key) > 2 Then
            If Not Dic.exists(Key) Then
                W = W + 1:              Dic.Add Key, W
                For Cot = 1 To Col
                    aKQ(W, Cot) = Arr(J, Cot)
                Next Cot
            End If
        End If
    Next J
    If W Then
        [M6].Resize(W, Col).Value = aKQ()
    End If
 End With
End Sub

 

[DMQ]

Em cám ơn anh @HUONGHCKT, bác @SA_DQ , bạn @thien-16 nhiều ạ.
Em có dùng code dùng công thức CountIfs rồi lọc >1,rồi xóa,(theo ý anh @HUONGHCKT) nhưng code chạy chậm hơn code của Anh @HUONGHCKT và bác @SA_DQ .

Sub XoaDong()
    Dim ws As Worksheet
    Dim lastRow As Long    
    
    Set ws = ThisWorkbook.Sheets("Sheet2")   
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual  
  
    
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    
    ' Thêm cột phụ (cột T)
    With ws
        .Range("T6:T" & lastRow).Formula = "=COUNTIFS(D$6:D6,D6,F$6:F6,F6,H$6:H6,H6)"
    End With
    
    ' Lọc các dòng có giá trị ở cột T > 1
    With ws.Range("T5:T" & lastRow)
        .AutoFilter Field:=1, Criteria1:=">1"
    End With
    
    ' Xóa các dòng đã lọc
    On Error Resume Next
    ws.Range("A6:Q" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    On Error GoTo 0
    
    ' Bỏ lọc
    ws.AutoFilterMode = False
    
    ' Xóa cột phụ
    ws.Columns("T").ClearContents      
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True     
    
    MsgBox "Đã xoa các dòng trùng lặp thành công!", vbInformation, "Hoàn tất"
End Sub

 

[DMQ]

Code của anh @HUONGHCKT có thể chỉnh tăng tốc lên được không ạ, em chạy code anh với 2543 dòng,cột từ A:Q mất 29.06 giây ạ.

 

[HUONGHCKT]

Code của anh @HUONGHCKT có thể chỉnh tăng tốc lên được không ạ, em chạy code anh với 2543 dòng,cột từ A:Q mất 29.06 giây ạ.

Nếu mục đích là chỉ để giữ lại dòng đầu tiên tìm thấy còn lại là Xóa các dòng trùng, kể cả dòng trống, thì tại sao bạn không dùng code của anh @SA_DQ.
Bạn chỉ cần thêm dòng code xóa bỏ hoàn toàn dữ liệu cũ và gán mảng kết quả vào ô định gán là được
... if W then
[A6].Resize(Rws, Col).Clearcontents
[Địa chỉ ô định gán kết quả].Resize(W, Col).Value = aKQ()
end if
Còn không thì bạn thử thêm các đoạn code :

Dim .....
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
' .EnableEvents = False
' .DisplayAlerts = False
End With
vào ngay sau khai báo biến

Và
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
' .EnableEvents = True
' .DisplayAlerts =true
End With
End Sub
trước khi end sub
và bỏ select đi
.....
Rng.Select
Selection.Delete Shift:=xlUp
....
Thành
.....
Rng.Delete Shift:=xlUp
.....
Chạy thử xem sao.

 

[Trần Văn Bình]

Lâu lâu cũng phải "văn ôn võ . . ." 1 lần

Sub XoaDongTrungDe1()
 Dim Arr(), Dic As Object
 Dim J As Long, Rws As Long, W As Integer, Col As Integer, Cot As Integer
 Dim Key As String

 With Sheet2
    Rws = .UsedRange.Rows.Count:       Col = .UsedRange.Columns.Count
    Set Dic = CreateObject("Scripting.Dictionary")
    Arr() = [A6].Resize(Rws, Col).Value
    ReDim aKQ(1 To Rws, 1 To Col)
    For J = 1 To UBound(Arr())
        Key = Arr(J, 4) & "@" & Arr(J, 6) & "|" & Arr(J, 8)
        If Len(Key) > 2 Then
            If Not Dic.exists(Key) Then
                W = W + 1:              Dic.Add Key, W
                For Cot = 1 To Col
                    aKQ(W, Cot) = Arr(J, Cot)
                Next Cot
            End If
        End If
    Next J
    If W Then
        [M6].Resize(W, Col).Value = aKQ()
    End If
 End With
End Sub

Mình Text thử thấy lỗi ngày dòng này
Rws = .UsedRange.Rows.Count: Col = .UsedRange.Columns.Count