Das Makro, nimmt zur Zeit Werte/Text aus einem Tabellenblatt und fügt diese in ein anderes ein, _ danach wird ein Druckauftrag gestartet, dann das ganze ohne Makro als kopie gespeichert und dann alles wieder zurück gesetzt:
Public Sub Seriendruck()
'Dieses Makro druckt den Bereich "Prüfprotokoll"
'mit jeweils einer Zeile der Werte aus "Messungen"
'und speichert eine Kopie unter dem Prüflingsnamen
'Start der For Schleife
For a = 1 To 1000
'Abfrage ob die jeweilige Zeile berücksichtigt werden soll
If CStr(Sheets("Messungen").Cells(a, 26)) = "x" Then
'Betriebsmittel
Sheets("Prüfprotokoll").Cells(3, 6).Value = CStr(Sheets("Messungen").Cells(a, 1))
'Fabrikat
Sheets("Prüfprotokoll").Cells(3, 16).Value = CStr(Sheets("Messungen").Cells(a, 2))
'Modell
Sheets("Prüfprotokoll").Cells(3, 26).Value = CStr(Sheets("Messungen").Cells(a, 3))
'Prüfling/Inventar Nr.
Sheets("Prüfprotokoll").Cells(6, 6).Value = CStr(Sheets("Messungen").Cells(a, 4))
'Schutzklasse ankreuzen
If CStr(Sheets("Messungen").Cells(a, 5)) = "1" Then
Sheets("Prüfprotokoll").Cells(6, 17).Value = "X"
Sheets("Prüfprotokoll").Cells(6, 19).Value = ""
Sheets("Prüfprotokoll").Cells(6, 21).Value = ""
ElseIf CStr(Sheets("Messungen").Cells(a, 5)) = "2" Then
Sheets("Prüfprotokoll").Cells(6, 17).Value = ""
Sheets("Prüfprotokoll").Cells(6, 19).Value = "X"
Sheets("Prüfprotokoll").Cells(6, 21).Value = ""
ElseIf CStr(Sheets("Messungen").Cells(a, 5)) = "3" Then
Sheets("Prüfprotokoll").Cells(6, 17).Value = ""
Sheets("Prüfprotokoll").Cells(6, 19).Value = ""
Sheets("Prüfprotokoll").Cells(6, 21).Value = "X"
Else
Sheets("Prüfprotokoll").Cells(6, 17).Value = ""
Sheets("Prüfprotokoll").Cells(6, 19).Value = ""
Sheets("Prüfprotokoll").Cells(6, 21).Value = ""
End If
'Standort/Nutzer
Sheets("Prüfprotokoll").Cells(6, 27).Value = CStr(Sheets("Messungen").Cells(a, 6))
'Besonderheiten
Sheets("Prüfprotokoll").Cells(8, 7).Value = CStr(Sheets("Messungen").Cells(a, 7))
'Grund der Prüfung ankreuzen
If CStr(Sheets("Messungen").Cells(a, 8)) = "e" Then
Sheets("Prüfprotokoll").Cells(11, 5).Value = "X"
Sheets("Prüfprotokoll").Cells(11, 11).Value = ""
Sheets("Prüfprotokoll").Cells(11, 21).Value = ""
Sheets("Prüfprotokoll").Cells(11, 27).Value = ""
ElseIf CStr(Sheets("Messungen").Cells(a, 8)) = "w" Then
Sheets("Prüfprotokoll").Cells(11, 5).Value = ""
Sheets("Prüfprotokoll").Cells(11, 11).Value = "X"
Sheets("Prüfprotokoll").Cells(11, 21).Value = ""
Sheets("Prüfprotokoll").Cells(11, 27).Value = ""
ElseIf CStr(Sheets("Messungen").Cells(a, 8)) = "ä" Then
Sheets("Prüfprotokoll").Cells(11, 5).Value = ""
Sheets("Prüfprotokoll").Cells(11, 11).Value = ""
Sheets("Prüfprotokoll").Cells(11, 21).Value = "X"
Sheets("Prüfprotokoll").Cells(11, 27).Value = ""
ElseIf CStr(Sheets("Messungen").Cells(a, 8)) = "i" Then
Sheets("Prüfprotokoll").Cells(11, 5).Value = ""
Sheets("Prüfprotokoll").Cells(11, 11).Value = ""
Sheets("Prüfprotokoll").Cells(11, 21).Value = ""
Sheets("Prüfprotokoll").Cells(11, 27).Value = "X"
Else
Sheets("Prüfprotokoll").Cells(11, 5).Value = ""
Sheets("Prüfprotokoll").Cells(11, 11).Value = ""
Sheets("Prüfprotokoll").Cells(11, 21).Value = ""
Sheets("Prüfprotokoll").Cells(11, 27).Value = ""
End If
'Prüfdatum
Sheets("Prüfprotokoll").Cells(27, 1).Value = CStr(Sheets("Messungen").Cells(a, 9))
'Sichtprüfung
Sheets("Prüfprotokoll").Cells(27, 4).Value = CStr(Sheets("Messungen").Cells(a, 10))
'R pe
Sheets("Prüfprotokoll").Cells(27, 7).Value = CStr(Sheets("Messungen").Cells(a, 11))
'R iso
Sheets("Prüfprotokoll").Cells(27, 10).Value = CStr(Sheets("Messungen").Cells(a, 12))
'R iso 2)
Sheets("Prüfprotokoll").Cells(27, 13).Value = CStr(Sheets("Messungen").Cells(a, 13))
'R iso 3)
Sheets("Prüfprotokoll").Cells(27, 17).Value = CStr(Sheets("Messungen").Cells(a, 14))
'U 0 2)
Sheets("Prüfprotokoll").Cells(27, 21).Value = CStr(Sheets("Messungen").Cells(a, 15))
'I pe
Sheets("Prüfprotokoll").Cells(27, 24).Value = CStr(Sheets("Messungen").Cells(a, 16))
'I ber
Sheets("Prüfprotokoll").Cells(27, 26).Value = CStr(Sheets("Messungen").Cells(a, 17))
'[W]
Sheets("Prüfprotokoll").Cells(27, 28).Value = CStr(Sheets("Messungen").Cells(a, 18))
'Folgedatum
Sheets("Prüfprotokoll").Cells(27, 30).Value = CStr(Sheets("Messungen").Cells(a, 19))
'Ende der Abfrage zur Berücksichtigung einer Zeile
End If
'Drucken
Sheets("Prüfprotokoll").Activate
If CStr(Sheets("Messungen").Cells(a, 26)) = "x" Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
'Kopie speichern
'Bildschirmaktualisierung abgeschalten
Application.ScreenUpdating = False
'Meldungen ausschalten
Application.DisplayAlerts = False
'Pfad und Name der Kopie
strDname = "C:\Users\brla1\Desktop\TEST\" & "Messprotokoll" & CStr(Sheets("Messungen"). _
_
Cells(a, 4))
'speichern
ActiveWorkbook.SaveAs strDname, FileFormat:=xlOpenXMLWorkbook
'Meldungen wieder einschalten
Application.DisplayAlerts = True
'Bildschirmaktualisierung eingeschalten
Application.ScreenUpdating = True
End If
'Alle Eintragungen löschen
If CStr(Sheets("Messungen").Cells(a, 26)) = "x" Then
Sheets("Prüfprotokoll").Cells(3, 6).Value = ""
Sheets("Prüfprotokoll").Cells(3, 16).Value = ""
Sheets("Prüfprotokoll").Cells(3, 26).Value = ""
Sheets("Prüfprotokoll").Cells(6, 6).Value = ""
Sheets("Prüfprotokoll").Cells(6, 17).Value = ""
Sheets("Prüfprotokoll").Cells(6, 19).Value = ""
Sheets("Prüfprotokoll").Cells(6, 21).Value = ""
Sheets("Prüfprotokoll").Cells(6, 27).Value = ""
Sheets("Prüfprotokoll").Cells(8, 7).Value = ""
Sheets("Prüfprotokoll").Cells(11, 5).Value = ""
Sheets("Prüfprotokoll").Cells(11, 11).Value = ""
Sheets("Prüfprotokoll").Cells(11, 21).Value = ""
Sheets("Prüfprotokoll").Cells(11, 27).Value = ""
Sheets("Prüfprotokoll").Cells(27, 1).Value = ""
Sheets("Prüfprotokoll").Cells(27, 4).Value = ""
Sheets("Prüfprotokoll").Cells(27, 7).Value = ""
Sheets("Prüfprotokoll").Cells(27, 10).Value = ""
Sheets("Prüfprotokoll").Cells(27, 13).Value = ""
Sheets("Prüfprotokoll").Cells(27, 17).Value = ""
Sheets("Prüfprotokoll").Cells(27, 21).Value = ""
Sheets("Prüfprotokoll").Cells(27, 24).Value = ""
Sheets("Prüfprotokoll").Cells(27, 26).Value = ""
Sheets("Prüfprotokoll").Cells(27, 28).Value = ""
Sheets("Prüfprotokoll").Cells(27, 30).Value = ""
End If
'Erhöhe counter "a" um 1
'Ende der For Schleife
Next a
End Sub
Erweitert werden muss jetzt noch, dass weder der Button noch das Tabellenblatt 'Messungen' in der Kopie enthalten ist.
Zum entfernen des Buttons habe ich hier etwas gefunden jedoch verstehe ich es noch nicht richtig. Und zum speichern ohne das Tabellenblatt konnte ich noch nichts finden.
Kann mir da jemand weiter helfen?