Speichern eines einzelnen Sheet

Hallo Dieter!
Probier das.

Sub BlattKopieren()
Dim strPath As String
Dim strName As String
Dim strWert As String
Dim shp As Shape
strPath = "D:\Excel\Sport\"         'Pfad
strName = ActiveSheet.Name          'Tabellenname
strWert = ActiveSheet.Range("C7")   'Dateiname - zusatz
Application.ScreenUpdating = False
ActiveSheet.Copy
With ActiveWorkbook
For Each shp In Sheets(1).Shapes    'Schaltflächen entfernen
shp.Delete
Next
With .VBProject.VBComponents(.VBProject.VBComponents(2).CodeModule).CodeModule
    .DeleteLines 1, .CountOfLines
End With
.Sheets(1).Cells.Locked = True  'Zellen sperren
.Sheets(1).Protect "test"       'Blattschutz setzen - Passwort anpassen
.SaveAs strPath & strName & " " & Format(Date, "dd mmyy") & " " & _
strWert & ".xls"
.Close
End With
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Ich hoffe das der Name so passt!
Die Schaltflächen und der VBA-Code werden entfern.
Die Zellen werden gesperrt und der Blattschutz wird
gesetzt. (Passwort = test)
Gruß Sepp

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim objwbk As Workbook Dim i As Long dim newname AS String Set objwbk = Workbooks.Add newname = Workbooks("Workbookname").Worksheets(1).Range("C7").Value & Date Workbooks("Workbookname").Worksheets(1).Copy After:=objwbk.Worksheets(3) For i = 1 To 3 objwbk.Worksheets(i).Delete Next objwbk.Saveas("D:\Excel\sport\" & newname) End Sub

Hallo Dieter


Sub test()
Dim objwbk As Workbook
Dim i As Long
dim newname AS String
Set objwbk = Workbooks.Add
'Bei Workbookname trägst du ein, wie die Arbeitsmappe heisst,
' aus der Du das Blatt eigens abspeichern willst
'In dieser Zeile wird dann der neue Name erstellt:
'Inhalt der Zelle C7 und das aktuelle Datum
newname = Workbooks("Workbookname").Worksheets(1).Range("C7").Value & Date
'Das erste Tabellenblatt wird dann in die neue Arbeitsmappe kopiert,
'und zwar ganz zum Schluss
Workbooks("Workbookname").Worksheets(1).Copy After:=objwbk.Worksheets(3)
'Jetzt werden noch die 3 leeren Tabellenblätter gelöscht,
'die ja in einer neuen arbeitsmappe sind
For i = 1 To 3
objwbk.Worksheets(i).Delete
Next
'zum Schluss speichern wir die neue arbeitsmappe unter einem
'festen Pfad mit oben erstellten Namen
objwbk.Saveas("D:\Excel\sport\" & newname)
End Sub

Ich hoffe, das ist jetzt etwas besser zu lesen.
Hoffentlich funktioniert's, ich habs noch nicht ausprobiert
Gruss Andi

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread