Nhờ viết code xóa dữ liệu trùng lặp

Liên hệ QC
D

duy_quang

Thành viên mới
Tham gia
7/1/22
Bài viết
3
Được thích
0
Kính nhờ Anh/chị giúp em xóa dữ liệu trùng lặp và đánh số thứ tự tự động sau mỗi lần xóa dữ liệu trùng lặp. (theo file đính kèm)
em trân trọng cảm ơn Anh/chị.
 

File đính kèm

  • xoadulieu.xlsx
    10.4 KB · Đọc: 32
Sắp xếp theo thời gian sắp xếp theo bầu chọn
duy_quang đã viết:
Kính nhờ Anh/chị giúp em xóa dữ liệu trùng lặp và đánh số thứ tự tự động sau mỗi lần xóa dữ liệu trùng lặp. (theo file đính kèm)
em trân trọng cảm ơn Anh/chị.
Nhấp chuột vào đây để mở rộng...
Bạn thử code này xem:
Mã: 
Option Explicit

Sub RemoveDuplicate()
Dim sArr(), dArr(), Dic As Object, I As Long, J As Long, sU1 As Long
With Sheets("Data")
    sArr = .Range("B4: C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    sU1 = UBound(sArr, 1)
    ReDim dArr(1 To sU1, 1 To 5)
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = sU1 To 1 Step -1
        If Not Dic.exists(sArr(I, 2)) Then
            J = J + 1
            Dic.Add sArr(I, 2), ""
            dArr(J, 1) = J
            dArr(J, 4) = sArr(I, 1)
            dArr(J, 5) = sArr(I, 2)
        End If
    Next
    For I = 1 To J
        dArr(I, 2) = dArr(J, 4)
        dArr(I, 3) = dArr(J, 5)
        J = J - 1
    Next
    .Range("K4").Resize(10000, 3).ClearContents
    .Range("K4").Resize(Dic.Count, 3) = dArr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
Nhattanktnn đã viết:
RemoveDuplicate
For I = sU1 To 1 Step -1
Nhấp chuột vào đây để mở rộng...
Viết vậy phải đảm bảo dữ liệu đã sắp xếp theo ngày tháng.

For i=1 to sU1 luôn
Ở vòng lặp đầu bạn gán key = nội dung cột C, item = (ngày tháng cột B, chỉ số)
Nếu key đã tồn tại thì đối chiếu ngày, nếu ngày lớn hơn thì ghi mới vào mảng kết quả.
Vậy là xong rồi.
 
Upvote 0
Nhattanktnn đã viết:
Bạn thử code này xem:
Mã: 
Option Explicit

Sub RemoveDuplicate()
Dim sArr(), dArr(), Dic As Object, I As Long, J As Long, sU1 As Long
With Sheets("Data")
    sArr = .Range("B4: C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    sU1 = UBound(sArr, 1)
    ReDim dArr(1 To sU1, 1 To 5)
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = sU1 To 1 Step -1
        If Not Dic.exists(sArr(I, 2)) Then
            J = J + 1
            Dic.Add sArr(I, 2), ""
            dArr(J, 1) = J
            dArr(J, 4) = sArr(I, 1)
            dArr(J, 5) = sArr(I, 2)
        End If
    Next
    For I = 1 To J
        dArr(I, 2) = dArr(J, 4)
        dArr(I, 3) = dArr(J, 5)
        J = J - 1
    Next
    .Range("K4").Resize(10000, 3).ClearContents
    .Range("K4").Resize(Dic.Count, 3) = dArr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
anh oi lam on xem lại giúp em, hay anh chạy luôn vào file em mô tả, vì em mới học nên copy nó ko chạy. em cảm ơn
 
Upvote 0
Dùng thử cái này. Kết quả sẽ đè lên dữ liệu gốc theo yêu cầu của bạn (không biết có phải yêu cầu là thế không?).
PHP: 
Option Explicit
Sub xoadulieu()
Dim Lr&, i&
Lr = Cells(Rows.Count, "C").End(xlUp).Row
    With CreateObject("Scripting.dictionary")
        For i = Lr To 4 Step -1
            If Not .exists(Cells(i, "C").Value) Then
                .Add Cells(i, "C").Value, Cells(i, "B").Value
            End If
        Next
            Range("A4:C" & Lr).Clear
            For i = .Count To 1 Step -1
                Cells(i + 3, "A").Value = i
                Cells(i + 3, "B").Value = .items()(.Count - i)
                Cells(i + 3, "C").Value = .keys()(.Count - i)
            Next
    End With
End Sub
 

File đính kèm

  • xoadulieu.xlsm
    19.6 KB · Đọc: 14
Upvote 0
bebo021999 đã viết:
Dùng thử cái này. Kết quả sẽ đè lên dữ liệu gốc theo yêu cầu của bạn (không biết có phải yêu cầu là thế không?).
PHP: 
Option Explicit
Sub xoadulieu()
Dim Lr&, i&
Lr = Cells(Rows.Count, "C").End(xlUp).Row
    With CreateObject("Scripting.dictionary")
        For i = Lr To 4 Step -1
            If Not .exists(Cells(i, "C").Value) Then
                .Add Cells(i, "C").Value, Cells(i, "B").Value
            End If
        Next
            Range("A4:C" & Lr).Clear
            For i = .Count To 1 Step -1
                Cells(i + 3, "A").Value = i
                Cells(i + 3, "B").Value = .items()(.Count - i)
                Cells(i + 3, "C").Value = .keys()(.Count - i)
            Next
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
đại ca bebo021999 xem lại giúp em, khi chạy nó bị mất tiêu đề cột ạ
 
Upvote 0
bebo021999 đã viết:
Dùng thử cái này. Kết quả sẽ đè lên dữ liệu gốc theo yêu cầu của bạn (không biết có phải yêu cầu là thế không?).
PHP: 
Option Explicit
Sub xoadulieu()
Dim Lr&, i&
Lr = Cells(Rows.Count, "C").End(xlUp).Row
    With CreateObject("Scripting.dictionary")
        For i = Lr To 4 Step -1
            If Not .exists(Cells(i, "C").Value) Then
                .Add Cells(i, "C").Value, Cells(i, "B").Value
            End If
        Next
            Range("A4:C" & Lr).Clear
            For i = .Count To 1 Step -1
                Cells(i + 3, "A").Value = i
                Cells(i + 3, "B").Value = .items()(.Count - i)
                Cells(i + 3, "C").Value = .keys()(.Count - i)
            Next
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Tại sao không lấy kết quả luôn khi duyệt dic.Mà lại phải thêm 1 vòng lặp nữa.
 
Upvote 0
duy_quang đã viết:
đại ca bebo021999 xem lại giúp em, khi chạy nó bị mất tiêu đề cột ạ
Nhấp chuột vào đây để mở rộng...
Theo file ví dụ thì dữ liệu bắt đầu từ dòng 4.

For i = Lr To 4 Step -1
Cells(i + 3, "A")
Range("A4:C" & Lr).Clear

Nếu khác thì chỉnh các thông số phía trên nhé.
Bài đã được tự động gộp:

snow25 đã viết:
Tại sao không lấy kết quả luôn khi duyệt dic.Mà lại phải thêm 1 vòng lặp nữa.
Nhấp chuột vào đây để mở rộng...
Câu này nghe quen quen, hỏi mấy lần rồi đúng không. Phải duyệt dic xong hết mới có KQ để so sánh chứ.
 
Upvote 0
@duy_quang Tham khảo thêm 1 cách dùng cho file bài 1
Mã: 
Option Explicit

Sub abc()
Dim i
With CreateObject("Scripting.Dictionary")
    For i = Sheet4.Range("A" & Rows.Count).End(xlUp).Row To 4 Step -1
        If .exists(Sheet4.Range("C" & i).Value) = 0 Then
            .Item(Sheet4.Range("C" & i).Value) = ""
        Else
            Sheet4.Rows(i).EntireRow.Delete
        End If
    Next i
End With
Sheet4.Range("A4", Sheet4.Range("A4").End(xlDown)).Formula = "=row()-3"
End Sub
 
Upvote 0
snow25 đã viết:
Tại sao không lấy kết quả luôn khi duyệt dic.Mà lại phải thêm 1 vòng lặp nữa.
Nhấp chuột vào đây để mở rộng...
Vòng lặp đầu tiên là duyệt dic, dữ liệu ban đầu có 7 dòng nên biến i phải chạy từ 1 tới 7. Ở đây lấy giá trị cuối nên i chạy từ 11 tới 4.
Vòng lặp thứ 2 là dán kết quả vào bảng tính, và số dòng là số phần tử của dic, sẽ <=7.
2 vòng có số loop khác nhau, sau lồng vô 1 được. Chưa kể kết quả sau khi VL 1 kết thúc là điều kiện cho VL 2
 
Upvote 0
CHAOQUAY đã viết:
@duy_quang Tham khảo thêm 1 cách dùng cho file bài 1
Mã: 
Option Explicit

Sub abc()
Dim i
With CreateObject("Scripting.Dictionary")
    For i = Sheet4.Range("A" & Rows.Count).End(xlUp).Row To 4 Step -1
        If .exists(Sheet4.Range("C" & i).Value) = 0 Then
            .Item(Sheet4.Range("C" & i).Value) = ""
        Else
            Sheet4.Rows(i).EntireRow.Delete
        End If
    Next i
End With
Sheet4.Range("A4", Sheet4.Range("A4").End(xlDown)).Formula = "=row()-3"
End Sub
Nhấp chuột vào đây để mở rộng...
Cái này mà nhiều dòng dữ liệu nó có bị quay đắm đuối không anh nhỉ
 
Upvote 0
Đề bài yêu cầu giữ lại dữ liệu nhập mới nhất theo ngày tháng ở cột B, chứ không nêu là giữ dữ liệu cuối theo dòng cột trong bảng.

1641875472969.png1641875644843.png

Nếu muốn duyệt từ dưới lên thì phải quy định rõ: Bảng dữ liệu đã được sắp xếp (chí ít là phải ghi quy ước như vậy, và yêu cầu trước khi chạy code phải thao tác sắp xếp bảng dữ liệu). Hoặc trong code phải có phần sắp xếp đó.

Chỉ cần 1 lần xét các phần tử là được, đã nêu ở bài #3 đó.
 
Upvote 0
Thử 1 cách khác
Mã: 
Sub ABC()
    Dim sArr(), Dic As Object, i&, j&, K&, Res(), Key
    Set Dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    With Sheets("data")
        sArr = .Range("A4:C" & .Range("B" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To UBound(sArr, 1), 1 To 3)
        For i = UBound(sArr, 1) To 1 Step -1
            If Dic.exists(UCase(sArr(i, 3))) = False Then
                Dic.Item(UCase(sArr(i, 3))) = i
            End If
        Next
        For Each Key In Dic.keys
            K = K + 1
            Res(K, 2) = sArr(Dic.Item(Key), 2)
            Res(K, 3) = sArr(Dic.Item(Key), 3)
        Next
            .Range("A4:C1000").ClearContents
            .Range("A4").Resize(K, 3).Value = Res
            .Range("A4").Resize(K, 3).Sort .Range("B3"), xlAscending
            .Range("A4").Value = 1
            .Range("A4").AutoFill .Range("A4").Resize(K), xlFillSeries
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
BuiQuangThuan đã viết:
Thử 1 cách khác
Mã: 
Sub ABC()
    Dim sArr(), Dic As Object, i&, j&, K&, Res(), Key
    Set Dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    With Sheets("data")
        sArr = .Range("A4:C" & .Range("B" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To UBound(sArr, 1), 1 To 3)
        For i = UBound(sArr, 1) To 1 Step -1
            If Dic.exists(UCase(sArr(i, 3))) = False Then
                Dic.Item(UCase(sArr(i, 3))) = i
            End If
        Next
        For Each Key In Dic.keys
            K = K + 1
            Res(K, 2) = sArr(Dic.Item(Key), 2)
            Res(K, 3) = sArr(Dic.Item(Key), 3)
        Next
            .Range("A4:C1000").ClearContents
            .Range("A4").Resize(K, 3).Value = Res
            .Range("A4").Resize(K, 3).Sort .Range("B3"), xlAscending
            .Range("A4").Value = 1
            .Range("A4").AutoFill .Range("A4").Resize(K), xlFillSeries
    End With
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Thử viết lại chỉ 1 vòng For i
 
Upvote 0
BuiQuangThuan đã viết:
Cái này mà nhiều dòng dữ liệu nó có bị quay đắm đuối không anh nhỉ
Nhấp chuột vào đây để mở rộng...
Thấy bạn @snow25 có ý tưởng hay nên học đòi viết thử vậy thôi ban. File mẫu dữ liệu cũng ít mà đầu bài lại không thấy nói "dữ liệu hàng vài trăm ngàn dòng" nên mới viết như vậy.
Nghe nói là lâu lâu "quay tay" thông nòng cũng tốt cho tuyến tiền liệt đấy bạn :D
 
Upvote 0
Một For
HieuCD đã viết:
Thử viết lại chỉ 1 vòng For i
Nhấp chuột vào đây để mở rộng...
Dạ, để em viết ạ!

Mã: 
Sub RemoveDuplicate()
Dim sArr, Dic As Object, I As Long, k As Long, vitri As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
    sArr = .Range("A4: C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    
    For I = 1 To UBound(sArr)
        If Not Dic.exists(sArr(I, 3)) Then
            k = k + 1
            Dic.Add sArr(I, 3), k
            sArr(k, 1) = k
            sArr(k, 2) = sArr(I, 2)
            sArr(k, 3) = sArr(I, 3)
        Else
            vitri = Dic.Item(sArr(I, 3))
            If sArr(vitri, 2) < sArr(I, 2) Then sArr(vitri, 2) = sArr(I, 2)
        End If
    Next
    .Range("K4").Resize(10000, 3).ClearContents
    .Range("K4").Resize(k, 3) = sArr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
duy_quang đã viết:
anh oi lam on xem lại giúp em, hay anh chạy luôn vào file em mô tả, vì em mới học nên copy nó ko chạy. em cảm ơn
Nhấp chuột vào đây để mở rộng...
Hiện thực hóa ý tưởng anh @befaint và viết vào file cho bạn luôn nhé:
Mã: 
Option Explicit

Sub RemoveDuplicate()
Dim sArr(), dArr(), Dic As Object, I As Long, J As Long, X, sU1 As Long
With Sheets("Data")
    sArr = .Range("B4: C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    sU1 = UBound(sArr, 1)
    ReDim dArr(1 To sU1, 1 To 3)
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 1 To sU1
        If Not Dic.exists(sArr(I, 2)) Then
            J = J + 1
            Dic.Add sArr(I, 2), Array(sArr(I, 1), J)
            dArr(J, 1) = J
            dArr(J, 2) = sArr(I, 1)
            dArr(J, 3) = sArr(I, 2)
        Else
            X = Dic.Item(sArr(I, 2))
            If sArr(I, 1) > X(0) Then
                dArr(X(1), 2) = sArr(I, 1)
            End If
        End If
    Next
    .Range("G4").Resize(10000, 3).ClearContents
    .Range("G4").Resize(Dic.Count, 3) = dArr
End With
Set Dic = Nothing
End Sub
 

File đính kèm

  • xoadulieu.xlsm
    21.2 KB · Đọc: 8
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

L
Dùng vlookup đưa kết quả không được
Trả lời
16
Đọc
100
Tuấn Bụng Bự
Tuấn Bụng Bự
Tuấn Bụng Bự
DataBase (CSDL) nào cho lập trình VBA trong Excel ?
Trả lời
7
Đọc
85
phuongnam366377
phuongnam366377
S
Tách 2 cột giờ ra, giờ vào
Trả lời
1
Đọc
21
Tuấn Bụng Bự
Tuấn Bụng Bự
X
  • Question
Xin trợ giúp code để lọc dữ liệu
Trả lời
8
Đọc
112
DeTong
D
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
195
Đọc
10K
ongke0711
ongke0711
Thi MInh Doan
Tính giá vé máy bay nếu tuyến bay ký hiệu là BL và chữ cái đầu của ký hiệu là A
Trả lời
1
Đọc
42
Hoàng Tuấn 868
H
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Thích
Trả lời
4
Đọc
155
HeSanbi
HeSanbi
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
10
Đọc
440
Duy Tùng 9x
Duy Tùng 9x
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
5
Đọc
136
nguyenhuong91
N
B
  • Question
Xin hướng dẫn tách 1 vùng dữ liệu sang thành nhiều sheet
Trả lời
3
Đọc
106
SA_DQ
SA_DQ
OverAC
Gặp gỡ giao lưu tại Hà Nội, chiều ngày 10/11/2025. cùng Ptm0412, OverAC và các anh chị thân thiết.
    • Thích
    • Yêu thích
Trả lời
5
Đọc
169
PhanTuHuong
PhanTuHuong
Hai Lúa Miền Tây
Nhập liệu, truy vấn dữ liệu qua Internet = VB.Net
    • Thích
2
Trả lời
26
Đọc
10K
phamduyhoang2907
P
P
Connection string cho SQL Express 2005
Trả lời
7
Đọc
7K
phamduyhoang2907
P
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
4
Đọc
189
CHAOQUAY
C
Quyen182
  • Question
Xin giúp code VBA để chèn ảnh có sẵn trong Excel vào phần comment
Trả lời
0
Đọc
76
Quyen182
Quyen182
Toanke063
  • Question
Xin hỏi code vba chuyển 1 file pdf bất kì thành ảnh
Trả lời
7
Đọc
180
cantl
C
HeSanbi
  • Đã giải quyết
ZaloExcel v2.92: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
2 3
Trả lời
55
Đọc
14K
HeSanbi
HeSanbi
Bebooby
Tách mã sản phẩm trong chuỗi thông tin
Trả lời
2
Đọc
85
NT Ngoc Yen
N
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
8
Đọc
178
thlpro
thlpro
S
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
2
Đọc
85
sakurasumo
S
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom