Code: Select all
Sub Duplicate()
Dim lRow As Long, wsLRow As Long, i As Long
Dim aCell As Range
Dim ws As Worksheet, sh As Worksheet
Dim strSearch As String
Dim show As Integer
show = 0
Set sh = ActiveSheet()
With sh
'~~> Get last row in Col A of the sheet
'~~> which got activated
'lRow = sh.Range("C6", sh.Range("C6").End(xlDown)).Rows.Count
lRow = Cells(Rows.Count, "C").End(xlUp).Row
'~~> Remove existing Color from the column
'~~> This is to cater for any deletions in the
'~~> other sheets so that cells can be re-colored
.Columns(3).Interior.ColorIndex = xlNone
'~~> Loop through the cells of the sheet which
'~~> got activated
For i = 6 To lRow
'~> Store the ID in a variable
strSearch = .Range("C" & i).Value
If strSearch <> "" Then
'~~> loop through the worksheets in the workbook
For Each ws In ThisWorkbook.Worksheets
'~~> This is to ensure that it doesn't
'~~> search itself
If ws.Name <> sh.Name Then
'~~> Get last row in Col A of the sheet
wsLRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
'~~> Use .Find to quick check for the duplicate
Set aCell = ws.Range("C6:C" & wsLRow).Find(What:=strSearch, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'~~> If found then color the cell red and exit the loop
'~~> No point searching rest of the sheets
If Not aCell Is Nothing Then
sh.Range("C" & i).Interior.ColorIndex = 3
show = 1
Exit For
End If
End If
Next ws
End If
Next i
End With
'------------------------------------------'
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long, iCntr2 As Long
With sh
'lastRow = Cells(Rows.Count, "C").End(xlUp).Row
'lastRow = sh.Range("C6", sh.Range("C6").End(xlDown)).Rows.Count
'lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
'lastRow = lRow
iCntr = 6
For iCntr = 6 To lRow
If Cells(iCntr, 6) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 3), Range("C6:C" & iCntr), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 3).Interior.ColorIndex = 3
show = 1
If iCntr = matchFoundIndex And iCntr <> lRow Then
iCntr2 = iCntr + 1
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 3), Range("C" & iCntr2 & ":C" & lRow), 0)
End If
If iCntr <> matchFoundIndex Then
Cells(iCntr, 3).Interior.ColorIndex = 3
show = 1
End If
End If
End If
Next
'-------------------------------------------'
End With
If show = 1 Then
MsgBox ("Duplicate ID Sheet")
End If
End Sub
(ปัญหาตอนนี้โค้ดของโปรแกรมปัจจุบันสามารถตรวจสอบใน Sheet อื่นๆได้ แล้วก็แจ้งเตือนได้ แต่ไม่สามารถตรวจสอบใน Sheet ตนเอง ถึงแม้เลขจะซ้ำกันก็ตาม)
เป้าหมาย
- ต้องการตรวจสอบและแจ้งเตือนเมื่อเลขซ้ำกันใน Sheet ตนเอง
- ต้องการตรวจสอบและแจ้งเตือนเมื่อตรวจสอบกับ Sheet อื่น
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
