...Mit Hyperlink :-)
Ramses
Hallo
hier die gewünschte Variante
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo myErrorHandler
Dim tarWks As String, qWks As Worksheet
Dim newMember As String
Dim tarC As Integer
Dim srchRng As Range
'Variablen
'Starttabelle
Set qWks = Worksheets(ActiveSheet.Name)
'Name der zu kopierenden Vorlagen Tabelle
tarWks = "Standard"
'Die zu prüfende Spalte
tarC = 1
newMember = Target.Value
'Makro hält an wenn eine andere Zelle
'als in Spalte 1 geändert wird
If Target.Column <> tarC Then Exit Sub
'Ereignis-Events ausschalten
Application.EnableEvents = False
'Inhalt löschen zum prüfen
Target.ClearContents
'Zellinhalt suchen ob mehrfach vorhanden
Set srchRng = Range(Cells(1, tarC), Cells(1000, tarC)).Find(What:=newMember, _
LookAt:=xlPart, LookIn:=xlFormulas)
If Not srchRng Is Nothing Then
MsgBox "Mitgliedsnummer existiert bereits." & Chr$(13) & _
"Makro wird abgebrochen", vbInformation + vbOKOnly, "Doppelter Eintrag"
'Inhalt wieder schreiben
'Ansonsten bleibt die Zelle gleich leer
'Target.Value = newMember
Application.EnableEvents = True
Exit Sub
End If
'Inhalt wieder einfügen
Target.Value = newMember
Worksheets(tarWks).Copy after:=Sheets(Worksheets.Count)
With ActiveSheet
.Name = newMember
.Range("B2") = newMember
End With
'Hyperlink anlegen
qWks.Hyperlinks.Add Anchor:=Range(Target.Address), Address:="", SubAddress:= _
newMember & "!A1", TextToDisplay:=newMember
ErrorExit:
'Ereignis-Events wieder einschalten
Application.EnableEvents = True
Exit Sub
myErrorHandler:
MsgBox "Fehler: " & Err.Number & Chr$(13) & Err.Description
Resume ErrorExit
End Sub
Gruss Rainer