ich habe folgenden Code ,der bis zu den Bereich Blatt umbenennen gut funktioniert. Ich habe im Forum auch schon Hilfe bekommen, kann es aber irgendwie nicht richtig umsetzen.
Wenn der Name schon vorhanden ist kann ich mit der inputBox einen neuen Namen eingeben, nach der Eingabe drück ich auf OK und wenn der Name den ich eingebe auch schon vorhanden ist soll der vorgang sooft wiederhold werden können, bis ich einen Namen eingebe, der noch nicht vorhanden ist, was leiter nicht klappt.
Private Sub CommandButtonTabelle2_Click()
Dim vLinks, ii As Integer, strB As String
Dim lstrFile As String, liLW As Integer
Application.EnableEvents = False
On Error GoTo fehler:
For liLW = 67 To 90
If Dir(Chr(liLW) & ":Mitarbeiterablage.xls") "" _
Then
lstrFile = Chr(liLW) & ":Mitarbeiterablage.xls" _
On Error GoTo 0
Exit For
weiter:
End If
Next
If lstrFile = "" Then
MsgBox "Auf keinem der Laufwerke von C: - Z: existiert eine Datei mit dem Namen '' _
Mitarbeiterablage.xls ''" & vbCrLf & "oder das Verzeichnis ''\Kalkulation-Kostenrechnung-Rö _
merbad'' ist nicht vorhanden", vbExclamation, "Hinweis"
Exit Sub
End If
Workbooks.Open Filename:=lstrFile
Windows("KalkulationKostenrechnungRömerbad25_08_2008.xls").Activate
Sheets("Tabelle2").Select
Sheets("Tabelle2").Copy after:=Workbooks("Mitarbeiterablage.xls").Sheets(1)
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Shapes("CommandButtonMA2").Left = Range("F1").Left 'CommandButton Positionieren
ActiveSheet.Shapes("CommandButtonMA2").Top = Range("F1").Top
strB = ActiveSheet.Cells(2, 2) ' Blatt umbenennen
If SheetTest(strB) Then
MsgBox "Das kopierte Blatt konnte in " & ActiveWorkbook.Name & _
" nicht umbenannt werden." & vbLf & vbLf & "Blatt '" & strB & _
" war bereits vorhanden.", vbExclamation, "weise hin..."
strB = InputBox("Neuer Name") 'da Name schon vorhanden, neuen Namen eingeben
10
ActiveSheet.Name = InputBox("Neuer Name") 'da Name schon vorhanden, neuen Namen eingeben
If strB = InputBox("Neuer Name") Then GoTo 10
ActiveSheet.Name = strB
Workbooks("Mitarbeiterablage.xls").Close True ' Mitarbeiterablage speichern + schließen
Else
ActiveSheet.Name = strB
Workbooks("Mitarbeiterablage.xls").Close True
End If
Windows("KalkulationKostenrechnungRömerbad25_08_2008.xls").Activate
Sheets("Tabelle2").Select
Sheets("Tabelle2").Range("B3,B4,B5,E2,E3,K9:O47,G10:I10,E15:G18,J14,V11:V22,AA11:AC22,P14:P17"). _
_
_
_
_
_
ClearContents
Range("A6") = 2
Range("A7") = 1
Sheets("Startcenter").Range("D13") = "Mitarbeiter 2"
Exit Sub
fehler:
Resume weiter
Application.EnableEvents = True
End Sub
Bitte um Hilfe
Gruß Werner