Nues Blatt

Hallo Freunde
Ich habe einen Problem und ich habe diesen Problem schon mal hier erwähnt jedoch die Lösung die erwünscht habe, habe ich nicht bekommen deshalb schreibe ich noch mal.
(Ich bedanke mich bei dem Mitglied "Mathiass" dass mir auch geholfen hat)!
Ich habe eine Excel Tabelle (Siehe File Unten)und funktioneiert so wenn ich einen Name (XXX) vergebe, wird ein neues Arbeitsblatt mit dem Name (XXX) mit vordefinierte Vorlage erzeugt.
Jetzt stellen Sie sich vor, ich habe 12 Blätter erzeugt (B1,B2,..,B12) aber nun möchte ich den Name vom Blatt (B3) zum (X) ändern. Ich möchte es so passieren, ohne ein neues Blatt mit dem neuen Name erzeugt zu werden und einfach der Name geändert werden.
https://www.herber.de/bbs/user/102956.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub VorlageKopieren(wsBez As String) Dim i As Integer, Check Dim Weiter As Boolean nochmal: Application.ScreenUpdating = False Weiter = False wsBez = Replace(wsBez, ":", "") wsBez = Replace(wsBez, "\", "") wsBez = Replace(wsBez, "/", "") wsBez = Replace(wsBez, "?", "") wsBez = Replace(wsBez, "*", "") wsBez = Replace(wsBez, "[", "") wsBez = Replace(wsBez, "]", "") With ThisWorkbook For i = 1 To .Sheets.Count If .Worksheets(i).Name = wsBez Then Check = MsgBox("Dieses Blatt existiert bereits!" & vbLf & "Soll es umbenannt _ werden?", vbYesNo) On Error GoTo nochmal If Check = 6 Then Worksheets(wsBez).Name = InputBox("Bitte jetzt umbenennen", , _ wsBez): Exit Sub If Check = 7 Then Exit Sub 'Nein End If Next Select Case Len(wsBez) Case Is > 31 wsBez = Left(wsBez, 31) Case Is = 0 If MsgBox("Zelle ist leer - Standardname für neues Blatt vergeben?", vbYesNo) = vbYes _ Then Weiter = True Else Exit Sub End If Case Else wsBez = wsBez End Select .Worksheets("Vorlage").Copy After:=Sheets(.Sheets.Count) If Weiter Then .ActiveSheet.Name = "Blatt " & .Sheets.Count + 1 Else: If Check 6 Then .ActiveSheet.Name = wsBez End If End With Worksheets("Steuerung").Activate Application.ScreenUpdating = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim namex If Not Intersect(Target, Range("B:B")) Is Nothing And _ Target.Cells.Count = 1 Then 'VorlageKopieren (Target.Value) namex = Target.Cells Sheets(namex).name = Application.InputBox("Bitte neuen Blattnamen eingeben", " _ neuer Name") End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler With Application .EnableEvents = False .Undo Vorher = Target.Value .Undo .EnableEvents = True If Vorher = "" Then 'Neu MsgBox "Blatt neu" ' hier jetzt das Anlegen des neuen Blattes ausführen ElseIf Vorher Target.Value Then ' geändert Sheets(Vorher).Name = Target Else MsgBox "Es wurde nichts geändert" Exit Sub End If End With Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

hi
Ich hab es nochmal ausgebaut und auch deinen Code optimiert
In den Codebereich der Tabelle "Steuerung"


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Dim Vorher As String
If Not Intersect(Target, Range("B:B")) Is Nothing And _
Target.Row > 1 And Target.Cells.Count = 1 Then
With Application
.EnableEvents = False
.Undo
Vorher = Target.Value
.Undo
.EnableEvents = True
If Vorher = "" And Target  "" Then 'Neu
MsgBox "Blatt neu"
ElseIf Vorher  Target.Value Then ' geändert
Sheets(Vorher).Name = Tauschen(Target.Value)
Exit Sub
ElseIf Target  "" Then
MsgBox "Es wurde nichts geändert"
Exit Sub
End If
VorlageKopieren (Tauschen(Target.Value))
End With
End If
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

In das Modul


Sub VorlageKopieren(wsBez As String)
Dim i As Integer
Dim Weiter As Boolean
Application.ScreenUpdating = False
Weiter = False
With ThisWorkbook
If wsBez = "" Then
If MsgBox("Zelle ist leer - Standardname für neues Blatt vergeben?", vbYesNo) =  _
vbYes Then _
Weiter = True
Else
For i = 1 To .Sheets.Count
If LCase(.Worksheets(i).Name) = LCase(wsBez) Then
MsgBox "Dieses Blatt existiert bereits!"
Exit Sub
End If
Next
End If
.Worksheets("Vorlage").Copy After:=Sheets(.Sheets.Count)
If Weiter Then
.ActiveSheet.Name = "Blatt " & .Sheets.Count + 1
ElseIf wsBez  "" Then
.ActiveSheet.Name = wsBez
End If
End With
Worksheets("Steuerung").Activate
Application.ScreenUpdating = True
End Sub
Function Tauschen(wsBez)
wsBez = Replace(wsBez, ":", "")
wsBez = Replace(wsBez, "\", "")
wsBez = Replace(wsBez, "/", "")
wsBez = Replace(wsBez, "?", "")
wsBez = Replace(wsBez, "*", "")
wsBez = Replace(wsBez, "[", "")
wsBez = Replace(wsBez, "]", "")
wsBez = Left(wsBez, 31)
Tauschen = wsBez
End Function

Gruß UweD

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Nues Blatt

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread