با سلام
از کد زیر استفاده کنید. در هر شیتی، در هر سلولی و هر مقداری که وارد کنید در صورت تکراری بودن، پیغام خطایی حاوی رفرنس تکرار آن را دریافت خواهید کرد:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim ws As Worksheet, Found As Range
Dim str As String, FirstAddress As String
Dim DupAddress As String, foundNum As Integer
str = Target.Value
If str = "" Then Exit Sub
For Each ws In ThisWorkbook.Worksheets
With ws
Set Found = .UsedRange.Find(what:=str, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not Found Is Nothing Then
FirstAddress = Found.Address
Do
foundNum = foundNum + 1
If Found.Address <> Target.Address Then
DupAddress = DupAddress & .Name & " " & Found.Address & vbCrLf
End If
Set Found = .UsedRange.FindNext(Found)
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
End With
Next ws
If Len(DupAddress) Then
Range(Target.Address).Select
MsgBox "Duplicate Value: """ & str & """ " & vbCr & DupAddress, vbOKOnly, "Duplicate Error!"
End If
End Sub
با احترام
1 سپاس