27 mình làm để ví dụ sau khi xóa thôi. sau khi xóa nó y như hình nek bạn
Thì Bạn làm sang cột bên cạnh xong dán nó vào. Ai lại chơi xóa chứng cứ như vậyÝ MÌNH XÓA LUÔN TRÊN VÙNG B5;B27 . còn Vùng D5
View attachment 233800
Thì cho nó một đoạn code những Cell nào giống nhau thì Merge and Center.
Dạ dữ liệu đó từ 1 phần mềm khác Xuất ra. em muốn xóa đi những ký tự trùng thôi chừa lại 1 ký tự đại diện thôi. Em không muốn Merge and Center. Mong anh chị giúp đở
Ý mình là xóa nhưng con số trùng nhau chỉ chừa lại 1 số đai diện nằm trên cùng thôi. Mình có thử áp dụng công thức của bạn vẫn không được.Thì Bạn làm sang cột bên cạnh xong dán nó vào. Ai lại chơi xóa chứng cứ như vậy
Sub XoaTrung()
Dim cel As Range
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
For Each cel In Selection
If Not Dic.exists(cel.Value) Then
Dic.Add cel.Value, ""
Else
cel.ClearContents
End If
Next
End Sub
Bạn thử làm cách sau:
=IF(COUNTIF($A$2:$A2,A2)=1,A2,"")dạ em cảm ơn anh.Code chạy hay quá. Em cảm ơn anh nhiều lắm
Sub XoaTrung()
Dim cel As Range
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
For Each cel In Range("B3:B5000")
If Not Dic.exists(cel.Value) Then
Dic.Add cel.Value, ""
Else
cel.ClearContents
End If
Next
End SubThử code sau, với điều kiện bất kỳ sheet nào đó có dữ liệu bắt đầu là B5.
Sub XoaDup()
Dim xCell As Range
Dim Chon As Range
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Set Chon = Range("B5", Range("B10000").End(xlUp))
For Each xCell In Chon
If Not Dic.exists(xCell.Value) Then
Dic.Add xCell.Value, ""
Else
xCell.ClearContents
End If
Next
End Subcảm ơn anh nhiều. Code hay lắm ạ
Hầu như việc này tôi đã góp ý cho rất nhiều thành viên rồi nhưng bạn lại không đọc.
Sub XoaTrung()
Dim cel As Range
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
For Each cel In Range("B3:c5000")
If Not Dic.exists(cel.Value) Then
Dic.Add cel.Value, ""
Else
cel.ClearContents
End If
Next
End Sub
Bạn sửa code của phuocam, đâu phải code trong bài viết của tôi.
Sub XoaDup()
Dim xCell As Range
Dim Chon As Range
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Set Chon = Range("B3", Range("C10000").End(xlUp))
For Each xCell In Chon
If Not Dic.exists(xCell.Value) Then
Dic.Add xCell.Value, ""
Else
xCell.ClearContents
End If
Next
End Sub
Sub xoatrungok()
Dim rg As Range, i As Long
Set rg = Range("B3:B43")
For i = rg.Rows.Count To 2 Step -1
If Application.Match(rg.Cells(i), rg, 0) <> i Then rg.Offset(i - 1, 0).Resize(1, 2).ClearContents
Next i
End SubVậy là bác lại hiểu nhầm rồi. Cột C đó mình không quan tâm. mình chỉ quan tâm cột mã hàng ( cột B) thôi, Nếu trùng cột B thì xóa dòng của cột B và xóa luôn dòng của cột C luôn bác ạ
Mỗi bài viết bạn đưa ra một kiểu hình nhưng không nêu cụ thể, rõ ràng cái mình muốn thực hiện thì tất cả các thành viên đều thấy, biết và hiểu như tôi, cụ thể:
Chỉ chọn cột Mã rồi chạy code
Sub XoaTrung()
Dim cel As Range
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
For Each cel In Selection
If Not Dic.exists(cel.Value) Then
Dic.Add cel.Value, ""
Else
cel.Resize(1, 2).ClearContents
End If
Next
End SubSub XoaTrung()
On Error Resume Next
Dim cel As Range
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For Each cel In Range("B3:B5000") ' Chi kiem tra tren cot B thoi
If Not Dic.exists(cel.Value) Then
Dic.Add cel.Value, ""
Else
cel.Resize(1, 2).ClearContents ' Cho nay 2 la 2 cot, e muon 4 cot hay n cot la em thay so Vi tri nay
End If
Next
Application.ScreenUpdating = True
End Sub cel.Resize(1, 2).ClearContentscel.EntireRow.ClearContents 'Cái này xóa nguyên 1 dòng cho khỏe
