Einzelne Exceltabellen kopieren in neue Mappe
Holger
ich habe ein Problem.
Ich habe eine Excelabelle mit mehreren Blättern.
Nun möchte ich mit einem Button einzele Sheets kopieren in eine andere Mappe und diese dann Speichern.
Jetzt habe ich einen Code der auch genauso geht, aber kann ich da nur ein Sheet Speichern.
Ich möchte aber mehrere kopieren.
Dann sollte aber auch der ganze VB Code aus der neuen Tabelle gelöcht werden und wenn möglich beim Kopieren nur Werte eingefügt werden.
Mein jetziger code der schon geht schaut so aus:
[code]
Sub Speichern_pf()
Dim varDateiname As Variant
Dim Dateiendung As String
Dateiendung = " .xls"
Dim Haendler As String
Haendler = ThisWorkbook.Worksheets("Beanstandung").Range("J18").Value
Dim fachberater As String
fachberater = ThisWorkbook.Worksheets("Beanstandung").Range("S11").Value
Dim verarbeiter As String
verarbeiter = ThisWorkbook.Worksheets("Beanstandung").Range("S18").Value
Dim Baustelle As String
Baustelle = ThisWorkbook.Worksheets("Beanstandung").Range("AA18").Value
ChDir "\"
ChDrive "c:\"
varDateiname = Application.GetSaveAsFilename("FPB" & ", " & Haendler & ", " & verarbeiter & _
", " & Baustelle & ", " & Format(Time, "ss") & Dateiendung, "Microsoft Excel-Dateien (*.xls),*.xls*,")
If TypeName(varDateiname) = "String" Then 'Wenn Dateiname angegeben wurde und mit OK bestä _
_
tigt :
ActiveSheet.Copy 'Kopiert nur das aktuelle Blatt in eine neue Mappe
'ActiveSheet.xlUnlockedCells
Dim Blatt As Worksheet, rngSichern As Range
Set Blatt = Worksheets("Frost Pfleiderer Beanstandung")
Set rngSichern = Blatt.[A1:AD166]
'Blatt.Unprotect
''Setzt alle "Gesperrt"-Haken auf "Aus"
Blatt.Cells.Locked = False
''Setzt die Haken im Bereich rngSichern = A1:B11
rngSichern.Locked = True
ActiveSheet.Protect "Test", DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.SaveAs varDateiname 'neue Mappe unter eingegebenenm Namen speichern
ActiveWorkbook.Close 'Neue Mappe wieder schliessen
'MsgBox "Dateiname :" & vbLf & vbLf & varDateiname, vbOKOnly + vbInformation, "Datei _
_
wurde gespeichert :"
End If
End Sub
[/code]