Tabellenblätter per Zelleneingabe umbenennen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer If Intersect(Target, Range("A1:A25")) Is Nothing Then Exit Sub With Sheets(1) For i = 1 To 25 If Sheets.Count "" Then If Application.WorksheetFunction.CountIf(.Range("A1:A25"), .Cells(i, 1)) = 1 Then Sheets(i + 1).Name = Sheets(1).Cells(i, 1) Else Sheets(1).Cells(i, 1) = "" MsgBox "Namen dürfen nicht doppelt vergeben werden", vbInformation, "Information" End If Else Sheets(i + 1).Name = "leer" & i End If Next i End With End Sub

Hallo Dirk,
probier das mal (gehört in den Code der Tabelle1):


Option Explicit
Dim strAlt As String
Private Sub Worksheet_Activate()
Cells(1, 2).Select
strAlt = ""
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target(1), Range("A1:A25")) Is Nothing Then Exit Sub
strAlt = Target(1)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ii As Integer
If Intersect(Target(1), Range("A1:A25")) Is Nothing Then Exit Sub
If strAlt = Target(1) Then Exit Sub
If IsEmpty(Target(1)) Then
If Not bFrei(strAlt) Then Worksheets(strAlt).Delete
strAlt = ""
ElseIf strAlt = "" Then
If WorksheetFunction.CountIf(Range("A1:A25"), Target(1)) > 1 Then
MsgBox "Der Name " & Target(1) & " ist schon vergeben."
Application.Undo
Exit Sub
ElseIf bFrei(Target(1)) Then
ii = WorksheetFunction.CountA(Range("A1:A" & Target(1).Row))
Worksheets.Add(after:=Sheets(ii)).Name = Target(1)
strAlt = Target(1)
End If
Else
If WorksheetFunction.CountIf(Range("A1:A25"), Target(1)) > 1 Then
MsgBox "Der Name " & Target(1) & " ist schon vergeben."
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Exit Sub
ElseIf bFrei(Target(1)) Then
If bFrei(strAlt) Then
MsgBox "Blatt " & strAlt & " gibt es noch nicht," & vbLf _
& "Blatt " & Target(1) & " wird neu angelegt."
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Target(1)
Else
Worksheets(strAlt).Name = Target(1)
End If
strAlt = Target(1)
End If
End If
Application.EnableEvents = False
Me.Select
Application.EnableEvents = True
End Sub
Private Function bFrei(strN As String) As Boolean
Dim ws As Worksheet
bFrei = True
For Each ws In Sheets
If ws.Name = strN Then
bFrei = False
Exit For
End If
Next ws
End Function

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Tabellenblätter per Zelleneingabe umbenennen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread