VBA finde Dubletten in Spalten- und Listenzeilennummer?

Question

Ich verwende den folgenden VBA-Code, um eine Spalte nach doppelten Werten zu durchsuchen. Wenn gefunden, dann möchte ich Zelle Q1 mit einem Hyperlink zu dieser Zeilennummer auffüllen.

Hier ist, was ich habe:

Private Sub Worksheet_Change(ByVal Target As Range) 

    If Target.Column = 15 And Len(Target.Value) > 0 Then    
     If Evaluate("Countif(O:O," & Target.Address & ")") > 1 Then 
      Range("P1").Value = "DUPLICATE ENTRY EXISTS"    
      Range("Q1").Formula= "=HYPERLINK()"      
     End If    
    End If 

End Sub 

Bitte kann mir jemand zeigen, wie die Zeilennummer des doppelten Wert erhalten?

Answer 1

würde ich die Range.Find Methode verwendet nur beide Überprüfung auf Duplikate zu erreichen und die Adresse zu bekommen. Möglicherweise möchten Sie den Hyperlink und die Zelle zu einem bestimmten Zeitpunkt löschen. Sie könnten überprüfen, ob es Dubletten gibt, und klären, ob das der Fall ist; oder Sie könnten nach mehreren Duplikaten suchen und sie in sequenziellen Zellen ausgeben. Alle möglichen Dinge.

BEARBEITEN Sie müssen auch entscheiden, wie mit der Situation umzugehen ist, in der ein Multicell-Bereich ist. Betrachten Sie die Situation, in der vollständig innerhalb der Spalte O ist und wo nicht.

Option Explicit 

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim R As Range, C As Range 
    Dim S As String 

Set R = Columns(15) 

If Not Intersect(Target, R) Is Nothing Then 
    Application.EnableEvents = False 
    Set C = R.Find(what:=Target.Text, after:=Target, LookIn:=xlValues, _ 
     lookat:=xlWhole, MatchCase:=False) 
    If C.Address <> Target.Address Then 
     S = C.Address(external:=True) 
     S = Mid(S, InStr(S, "]") + 1) 
     Range("q1").Hyperlinks.Delete 
     Range("Q1").Hyperlinks.Add Anchor:=Range("q1"), _ 
      Address:="", SubAddress:=S, _ 
      TextToDisplay:=C.Address, ScreenTip:="Duplicate Entry" 

    Else 'Clear Q1 if no duplicate 
     Range("Q1").Clear 
    End If 
End If 
Application.EnableEvents = True 

End Sub 

Answer 2

Probieren Sie den Code unten, es ist nicht so einfach wie ich es gerne hätte, aber es funktioniert.

Sobald Sie feststellen, dass der aktuelle Wert in Spalte "O" ein Duplikat hat, verwende ich die Find Methode, um die nächste Übereinstimmung zu finden.

-Code

Private Sub Worksheet_Change(ByVal Target As Range) 

    Application.EnableEvents = False 
    If Target.Column = 15 And Len(Target.Value) > 0 Then 

     If Evaluate("Countif(O:O," & Target.Address & ")") > 1 Then 
      Range("P1").Value = "DUPLICATE ENTRY EXISTS" 

      Dim RowDup As Long 
      Dim FindRng As Range 
      Dim LastRow As Long 

      LastRow = Cells(Rows.Count, Target.Column).End(xlUp).Row ' get last row with data in Column "O" 

      If Target.Row = 1 Then 
       Set FindRng = Range(Cells(Target.Row + 1, Target.Column), Cells(LastRow, Target.Column)) 
      Else ' define a search range, substract target cell from active range in column "O" 
       Set FindRng = Application.Union(Range(Cells(1, Target.Column), Cells(Target.Row - 1, Target.Column)), Range(Cells(Target.Row + 1, Target.Column), Cells(LastRow, Target.Column))) 
      End If 

      ' find thr row number in the column O (except Target cell) 
      RowDup = FindRng.Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _ 
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row 

      ' get the hyperlink to the cell where the first dupliacte exists 
      Range("Q1").Formula = "=HYPERLINK(" & Range(Cells(RowDup, Target.Column), Cells(RowDup, Target.Column)).Address & ")" 
     End If 
    End If 
    Application.EnableEvents = True 

End Sub