Option
Explicit
Public
Sub
CopySheetAndProtect()
Dim
wksSource
As
Excel.Worksheet
Dim
wksNew
As
Excel.Worksheet
Dim
strNewName
As
String
Dim
strNewPassword
As
String
If
Not
TypeOf
ThisWorkbook.ActiveSheet
Is
Excel.Worksheet
Then
Call
MsgBox(
"Das aktuelle Blatt muss ein Tabellenblatt sein!"
, vbExclamation)
Exit
Sub
End
If
Set
wksSource = ThisWorkbook.ActiveSheet
Do
strNewName = Trim$(InputBox(
"Neuer Name: "
,
"Aktuelle Tabelle kopieren"
,
"Tabelle"
))
If
strNewName =
""
Then
Exit
Sub
On
Error
Resume
Next
Set
wksNew =
Nothing
Set
wksNew = ThisWorkbook.Worksheets(strNewName)
On
Error
GoTo
0
If
Not
wksNew
Is
Nothing
Then
Call
MsgBox(
"Ein Tabellenblatt mit dem Namen '"
& strNewName &
"' existiert bereits!"
& vbNewLine & _
"Bitte geben sie einen anderen Namen ein."
, vbExclamation)
End
If
Loop
Until
wksNew
Is
Nothing
strNewPassword = Trim$(InputBox(
"Passwort: "
,
"Tabellenschutz"
,
"Tabelle"
))
If
strNewPassword =
""
Then
Exit
Sub
With
wksSource.Parent
Call
wksSource.Copy(After:=.Sheets(.Sheets.Count))
Set
wksNew = .Worksheets(.Worksheets.Count)
End
With
wksNew.Name = strNewName
Call
wksNew.Protect(strNewPassword)
Call
MsgBox(
"Das Tabellenblatt '"
& strNewName &
"' wurde angelegt und geschützt."
, vbInformation)
End
Sub