Code zum SheetNamen ändern - bitte sehr

Sub SheetsRename()
Dim i As Integer
Dim ws As Worksheet
Dim strName As String
Dim Cell1 As String
Dim Cell2 As String
Dim strMeldung1 As String, strTitel1 As String
Dim strMeldung2 As String, strTitel2 As String
Dim strVorschlag As String
Dim objMSR As Object
Dim intPopUp As Integer
Set objMSR = CreateObject("WScript.Shell")
i = 0
strMeldung1 = "Bitte die erste Zelle für den Tabellennamen eingeben"
strMeldung2 = "Bitte die zweite Zelle für den Tabellennamen eingeben, auf Abbrechen klicken  _
falls nicht gewünscht"
strVorschlag = "A1"
strTitel1 = "Erste Zelle für Tabellenblattnamen ermitteln"
strTitel2 = "Zweite Zelle für Tabellenblattnamen ermitteln"
Cell1 = InputBox(strMeldung1, strTitel1, strVorschlag)
If Cell1 = "" Then
MsgBox "Kein Wert eingegeben, Abbruch!"
Exit Sub
Else
strMeldung1 = "Folgende Zelle wurde ausgewählt: " & Cell1
intPopUp = objMSR.Popup(strMeldung1, 1)
i = 1
End If
Cell2 = InputBox(strMeldung2, strTitel2, strVorschlag)
If Cell2 = "" Then
MsgBox "Kein Wert eingegeben, Tabellennamen werden nur aus Zelle " & Cell1 & "  _
ermittelt"
Else
strMeldung2 = "Folgende Zelle wurde ausgewählt: " & Cell2
intPopUp = objMSR.Popup(strMeldung2, 1)
i = i + 1
End If
For Each ws In Worksheets
ws.Activate
If i = 2 Then
strName = Range(Cell1) & " " & Range(Cell2)
Else
strName = Range(Cell1)
End If
If ws.Name = strName Then
MsgBox "Ein Tabellenblatt mit dem Namen " & strName & " existiert bereits."
Exit Sub
End If
ws.Name = strName
Next ws
Application.Dialogs(xlDialogSaveAs).Show
End Sub