einzelne Tabelle aus einer Arbeitsmappe speichern

Sub BlattSpeichern()
Dim sPath As String, sWks As String, sFile As String
Dim index%
On Error GoTo ErrH
sPath = Application.DefaultFilePath
If (Right(sPath, 1) <> "\") Then sPath = sPath & "\"
sWks = InputBox(prompt:="Blattname", _
Default:=BLATTNAME$)
If ((sWks = "") Or _
(InStr(1, sWks, ":") > 0) Or _
(InStr(1, sWks, "\") > 0) Or _
(InStr(1, sWks, "/") > 0) Or _
(InStr(1, sWks, "?") > 0) Or _
(InStr(1, sWks, "*") > 0) Or _
(InStr(1, sWks, "[") > 0) Or _
(InStr(1, sWks, "]") > 0) Or _
(Len(sWks) > 31)) Then sWks = BLATTNAME$
sFile = InputBox(prompt:="Dateiname", _
Default:=sPath & DATEINAME$ & ".xls")
ActiveSheet.Copy
ActiveSheet.Name = sWks
ActiveWorkbook.SaveAs sFile
MsgBox "Tabelle kopiert als : " & sWks & vbCrLf & _
"In Verzeichniss : " & ActiveWorkbook.Path & vbCrLf & _
"Mit dem Namen : " & ActiveWorkbook.Name, vbInformation
Exit Sub
ErrH:
' falls versucht datei mehrmals mit dem selben namen in den selben verz.
' zu speichern -> exception 1004 -> neue dateineme := dateiname + index% -> neuer versuch datei zu speichern
If (Err.Number = 1004) Then
If (index% < 1000) Then
index% = index% + 1
sFile = sPath & DATEINAME$ & index% & ".xls"
Resume
Else
MsgBox "Variable index% zu Hoch!", vbCritical: End
End If
Else
MsgBox "Laufzeitfehler : " & vbCrLf & Err.Description & vbCrLf & "Fehlernummer : " & Err.Number, vbCritical
End If
End Sub