AW: Tabblatt kopieren + umbenennen
11.01.2021 18:48:43
Oisse
Hallo Mildred,
denkst Du, Du könntest meinen Code trotzdem mal testen?
Als ich Deinen getestet habe, auch bei Target.Column (5) hat´s bei mir nicht so funktioniert.
Ich habe deswegen "Nam" geschrieben weil "Name" in Excel fest vergeben ist und deshalb nicht verwendet werden sollte und das ist auch der Grund, warum er das Tabellenblatt "Deckblatt Pos 1-4" umbenennt, weil er unter "Name" den Namen des aktuellen Tabellenblattes schreibt.
Wenn Du Dir meinen Code ansiehst, erkennst Du, dass "Nam" als "String" dimensioniert wurde.
Allerdings habe ich vergessen, auch "mstrSheetname" als "String" zu dimensionieren.
Übrigens müsstest Du auch das Calculate Ereignis löschen, weil er sonst immer nach einem falschen Namen die Tabellenblätter durchsucht.
Deshalb also der code nochmal:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Fehler As Integer, ws As Object
Dim Nam, mstrSheetname As String
If Target.Column = 5 Then
Select Case Target.Row
Case 12, 18, 24, 30
If Not IsEmpty(Cells(Target.Row, 5).Value) Then
mstrSheetname = Left("ICTP " & Replace(Cells(Target.Row, 5), "/", ""), 25)
If MsgBox("Tabellenblatt mit Name """ & mstrSheetname & """ anlegen?", _
vbYesNo, "Blatt Vorlage kopieren") = vbYes Then
For Each ws In ThisWorkbook.Worksheets
If ws.Name = mstrSheetname Then
MsgBox "Blatt mit dem eingegeben Namen " & mstrSheetname _
& " existiert bereits!"
Target.Select
Application.ScreenUpdating = True
Exit Sub
End If
Next
Application.ScreenUpdating = False
With Worksheets("Tabblatt kopieren")
.Visible = xlSheetVisible
.Copy Before:=Worksheets("Tabblatt kopieren")
.Visible = xlSheetVeryHidden
End With
ActiveSheet.Name = Left(mstrSheetname, 25)
End If
End If
If IsEmpty(Cells(Target.Row, 5).Value) Then
For Each ws In ThisWorkbook.Worksheets
If ws.Name = mstrSheetname Then
If MsgBox("Das Sheet ''" & mstrSheetname & "'' löschen?", vbQuestion Or _
vbYesNo, "Abfrage") = vbYes Then
Application.DisplayAlerts = False
Worksheets(mstrSheetname).Delete
End If
Exit For
End If
Next ws
End If
Case Else
End Select
End If
If Target.Column = 11 Then
Select Case Target.Row
Case 16, 22, 28, 34
Nam = Left(Replace("ICTP " & Cells(Target.Row - 4, 5), "/", ""), 25)
If Not IsEmpty(Cells(Target.Row, 11).Value) Then
If MsgBox("Tabellenblatt mit Name " & Nam & " anlegen ?", _
vbYesNo, "Blatt Vorlage kopieren") = vbYes Then
For Each ws In ThisWorkbook.Worksheets
If ws.Name = Nam Then
MsgBox "Blatt mit dem eingegeben Namen " & mstrSheetname _
& " existiert bereits!"
Target.Select
Application.ScreenUpdating = True
Exit Sub
End If
Next
With Worksheets("Tabelle2")
.Visible = xlSheetVisible
.Copy Before:=Worksheets("Tabelle2")
.Visible = xlSheetVeryHidden
ActiveSheet.Name = Nam
End With
End If
End If
If IsEmpty(Cells(Target.Row, 11).Value) Then
For Each ws In ThisWorkbook.Worksheets
If ws.Name = Nam Then
If MsgBox("Das Sheet ''" & Nam & "'' löschen?", vbQuestion Or vbYesNo, " _
Abfrage") = vbYes Then
Application.DisplayAlerts = False
Worksheets(Nam).Delete
End If
Exit For
End If
Next ws
End If
Case Else
End Select
End If
Worksheets("Deckblatt Pos 1-4").Select
End Sub
L.G.
Oisse