Option Explicit
Sub TimTrung()
Dim eRw As Long, Ww As Long: Dim MyAdd As String
Dim Rng As Range, sRng As Range
eRw = [f65500].End(xlUp).Row: Columns("G:G").Clear
For Ww = 1 To eRw
With Cells(Ww, "F")
If .Offset(, 1).Value = "" Then
Set Rng = .Offset(1).Resize(eRw)
Set sRng = Rng.Find(.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
sRng.Offset(, 1) = .Address
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
End With
Next Ww
End Sub
Mình làm code này. Bạn bôi đen vùng muốn kiểm tra. Ấn nút. Những ô bị trùng sẽ bị tô màu đỏ.
Sub KiemtraDulieutrung()
Dim cell As Range
For Each cell In Selection
If WorksheetFunction.CountIf(Selection, cell) > 1 Then cell.Interior.ColorIndex = 3
Next
End SubBạn bôi đen vùng cần kiểm tra và bấm nút :
Sub KiemtraDulieutrung2()
Dim cell As Range, Str As String, count As Long
Str = "-"
For Each cell In Selection
If WorksheetFunction.CountIf(Selection, cell) > 1 And InStr(1, Str, cell) = 0 Then
count = count + 1
Str = Str & cell & "-"
End If
Next
MsgBox "Co " & count & " so bi trung. Cac so do la :" & Chr(10) & Str
End Sub
Danh cải tiến lại. cho 1 InputBox và chỉ cần đặt con trỏ vào 1 cell nào đó trong vùng là được rồi ---> Đôi khi vùng dử liệu lớn quá, việc quét chọn bằng tay cũng khá khó khăn!
Sub DemDulieutrung()
Dim cell As Range, Str As String
Dim n As Long
Str = ""
For Each cell In Selection
n = WorksheetFunction.CountIf(Selection, cell)
If n > 1 And InStr(1, Str, cell) = 0 Then Str = Str & cell & " trung: " & n & " lan " & Chr(10)
Next
MsgBox Str
End Sub
(
