AW: einzelnes Blatt kopieren
21.10.2012 12:16:49
fcs
Hallo Klaus,
hier mein Vorschlag. Zum Testen hab ich die Seitevorschau eingebaut. Das nuss du noch anpassen. Ebenso ggf. das Berechnen des Dateinamens der gedruckten Tabellenblatter.
Gruß
Franz
Sub Liste_Drucken_Speichern()
Dim wksEingabe As Worksheet
Dim wksForm As Worksheet
Dim Zeile_E As Long
Dim varOrdner, wbNeu As Workbook, strFileName As String, intCount As Integer
'Zielordner auswählen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Zielordner wählen für die gedruckten Tabellenblätter"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
Set wksEingabe = ActiveWorkbook.Worksheets("Tabelle1")
Set wksForm = ActiveWorkbook.Worksheets("Tabelle2")
With Application
End With
With wksEingabe
intCount = 0
For Zeile_E = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
intCount = intCount + 1 'fortlaufender Zähler für Dateien
Application.StatusBar = "Datenzeile Nr. " & intCount & " wird gedruckt"
'Daten in Formular eintragen
wksForm.Range("B2") = .Cells(Zeile_E, 1).Value
wksForm.Range("B3") = .Cells(Zeile_E, 2).Value
wksForm.Range("B5") = .Cells(Zeile_E, 3).Value
wksForm.Range("B7") = .Cells(Zeile_E, 4).Value
wksForm.Range("B8") = .Cells(Zeile_E, 5).Value
With wksForm
.Calculate 'Falls erforderlich
'.PrintOut
.PrintPreview
'Dateiname für Datei mit Tabellenblatt, hier am Namen noch keine Datei-Endung _
anfügen, das macht Excel automatisch über das Fileformat
strFileName = .Range("B2").Text & Format(Now, " YYYYMMDD hhmmss")
strFileName = varOrdner & Application.PathSeparator & strFileName
.Copy
Set wbNeu = ActiveWorkbook
With wbNeu
'FileFormat ggf. anpassen/weglassen
'xlWorkbookNormal = Excel 2007/2010 ein 97-2003-Format
'xlOpenXMLWorkbook = 2007 und neuer
.SaveAs Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook
.Close savechanges:=False
End With
Set wbNeu = Nothing
End With
Next Zeile_E
End With 'wksEingabe
Beenden:
With Application
.StatusBar = False
.ScreenUpdating = True
End With
End Sub