Mehrere Tabellenblätter in einer Datei speichern
06.02.2017 11:02:20
Beermann
https://www.herber.de/cgi-bin/callthread.pl?index=1536284#1536284
Ich konnte krankheits bedingt erst jetzt Antworten und aus irgendeinem Grund geht das nicht in dem alten Beitrag (oder ich find nicht wo)
Naja bevor ich mich über die Forumsstrucktur hier auslasse zurück zum Thema.
Erstmal ein Dankeschön an Michael (excelerated) das ganze läuft erheblich schneller und jeder Bruchteil einer Sekunde ist durchaus merkbar bei mehr als 5000 Dateien die hier gedruckt bzw gespeichert werden sollen. Auch die Idee den Knopf auf das Tabellenblatt "Messungen" zu verschieben ist bestechend einfach und funktioniert wie erwartet problemlos ;-)
Gespeichert werden müssen die Tabellenblätter "Prüfprotokoll" und "Statistik" deswegen hatte ich ursprünglich danach gefragt ein Tabellenblatt zu löschen statt eines zu speichern.
Ich habe versucht mehrere auszuwählen und zu speichern mit folgenden Zeilen
Worksheets(Array("Prüfprotokoll", "Statistik")).Copy
ActiveWorkbook.SaveAs strdname, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
klappt aber nicht! Bekomme gar keine Datei mehr gespeichert.
Ach ja zu der Frage warum die Eintragungen wieder gelöscht werden müssen. Ich hatte den Block vorher auch nicht drin weil genau wie Michael (excelerated) geschrieben hat "die werden ja eh überschrieben", werden sie aber nicht immer, da nicht immer alle Felder ausgefüllt werden und genau dann taucht der Wert von vorher auf und es wird falsch.
Desweiteren ist ein neues Problem entstanden und zwar sind einige der Prüflingsbezeichnungen in ca diesem Format: 7-1-100 und da macht Excel dann ein Datum raus.
Es müssen also irgendwie folgende Zellen als Text formatiert werden bevor die Werte vom Makro _ eingefügt werden:
'Prüfling/Inventar Nr.
.Cells(6, 6)
'Prüfdatum
.Cells(27, 1)
'Folgedatum
.Cells(27, 30)
Nein nicht alle Zellen weil im Tabellenblatt "Statistik" Diagramme sind die sich auf Zahlen des Tabellenblatts "Prüfprotokoll" beziehen und ja auch die Datumsangaben da sie vom gegebenem Platz einmal im Format Jan 17 und einmal im Format 01.01.17 angegeben werden. Die Standart Datumsformatierung von Excel nutzt jedoch dieses Format 01.01.2017 was zu lang ist.
Das gesammte Makro sieht jetzt so aus:
Public Sub Seriendruck()
Dim a&, maxZ& '& = as long: a wie gehabt, maxZ=unterste Zeile
Dim arr
Dim strdname As String
'Dieses Makro druckt den Bereich "Prüfprotokoll"
'mit jeweils einer Zeile der Werte aus "Messungen"
'und speichert eine Kopie unter dem Prüflingsnamen
' falls nicht "Messungen" aktiv, dann
With Sheets("Messungen")
maxZ = .Range("Z" & .Rows.Count).End(xlUp).Row
arr = .Range("A1:Z" & maxZ) ' ALLES in ein Array geladen
End With
With Sheets("Prüfprotokoll")
'Start der For Schleife
For a = 1 To maxZ ' nur bis nix mehr da
'Abfrage ob die jeweilige Zeile berücksichtigt werden soll
If CStr(arr(a, 26)) = "x" Or _
CStr(arr(a, 25)) = "x" Then
'Betriebsmittel
.Cells(3, 6).Value = CStr(arr(a, 1))
'Fabrikat
.Cells(3, 16).Value = CStr(arr(a, 2))
'Modell
.Cells(3, 26).Value = CStr(arr(a, 3))
'Prüfling/Inventar Nr.
.Cells(6, 6).Value = CStr(arr(a, 4))
'Schutzklasse ankreuzen
If CStr(arr(a, 5)) = "1" Then
.Cells(6, 17).Value = "X"
.Cells(6, 19).Value = ""
.Cells(6, 21).Value = ""
ElseIf CStr(arr(a, 5)) = "2" Then
.Cells(6, 17).Value = ""
.Cells(6, 19).Value = "X"
.Cells(6, 21).Value = ""
ElseIf CStr(arr(a, 5)) = "3" Then
.Cells(6, 17).Value = ""
.Cells(6, 19).Value = ""
.Cells(6, 21).Value = "X"
Else
.Cells(6, 17).Value = ""
.Cells(6, 19).Value = ""
.Cells(6, 21).Value = ""
End If
'Standort/Nutzer
.Cells(6, 27).Value = CStr(arr(a, 6))
'Besonderheiten
.Cells(8, 7).Value = CStr(arr(a, 7))
'Grund der Prüfung ankreuzen
If CStr(arr(a, 8)) = "e" Then
.Cells(11, 5).Value = "X"
.Cells(11, 11).Value = ""
.Cells(11, 21).Value = ""
.Cells(11, 27).Value = ""
ElseIf CStr(arr(a, 8)) = "w" Then
.Cells(11, 5).Value = ""
.Cells(11, 11).Value = "X"
.Cells(11, 21).Value = ""
.Cells(11, 27).Value = ""
ElseIf CStr(arr(a, 8)) = "ä" Then
.Cells(11, 5).Value = ""
.Cells(11, 11).Value = ""
.Cells(11, 21).Value = "X"
.Cells(11, 27).Value = ""
ElseIf CStr(arr(a, 8)) = "i" Then
.Cells(11, 5).Value = ""
.Cells(11, 11).Value = ""
.Cells(11, 21).Value = ""
.Cells(11, 27).Value = "X"
Else
.Cells(11, 5).Value = ""
.Cells(11, 11).Value = ""
.Cells(11, 21).Value = ""
.Cells(11, 27).Value = ""
End If
'Prüfdatum
.Cells(27, 1).Value = CStr(arr(a, 9))
'Sichtprüfung
.Cells(27, 4).Value = CStr(arr(a, 10))
'R pe
.Cells(27, 7).Value = CStr(arr(a, 11))
'R iso
.Cells(27, 10).Value = CStr(arr(a, 12))
'R iso 2)
.Cells(27, 13).Value = CStr(arr(a, 13))
'R iso 3)
.Cells(27, 17).Value = CStr(arr(a, 14))
'U 0 2)
.Cells(27, 21).Value = CStr(arr(a, 15))
'I pe
.Cells(27, 24).Value = CStr(arr(a, 16))
'I ber
.Cells(27, 26).Value = CStr(arr(a, 17))
'[W]
.Cells(27, 28).Value = CStr(arr(a, 18))
'Folgedatum
.Cells(27, 30).Value = CStr(arr(a, 19))
'Ende der Abfrage zur Berücksichtigung einer Zeile
End If
'Drucken
Sheets("Prüfprotokoll").Activate
If CStr(arr(a, 26)) = "x" Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If
'Seichern
If CStr(arr(a, 25)) = "x" Then
'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(arr(a, 4))
'speichern
Worksheets(Array("Prüfprotokoll", "Statistik")).Copy
ActiveWorkbook.SaveAs strdname, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
'Meldungen wieder einschalten
Application.DisplayAlerts = True
'Bildschirmaktualisierung eingeschalten
Application.ScreenUpdating = True
End If
'Alle Eintragungen löschen
If CStr(arr(a, 26)) = "x" Or _
CStr(arr(a, 25)) = "x" Then
.Cells(3, 6).Value = ""
.Cells(3, 16).Value = ""
.Cells(3, 26).Value = ""
.Cells(6, 6).Value = ""
.Cells(6, 17).Value = ""
.Cells(6, 19).Value = ""
.Cells(6, 21).Value = ""
.Cells(6, 27).Value = ""
.Cells(8, 7).Value = ""
.Cells(11, 5).Value = ""
.Cells(11, 11).Value = ""
.Cells(11, 21).Value = ""
.Cells(11, 27).Value = ""
.Cells(27, 1).Value = ""
.Cells(27, 4).Value = ""
.Cells(27, 7).Value = ""
.Cells(27, 10).Value = ""
.Cells(27, 13).Value = ""
.Cells(27, 17).Value = ""
.Cells(27, 21).Value = ""
.Cells(27, 24).Value = ""
.Cells(27, 26).Value = ""
.Cells(27, 28).Value = ""
.Cells(27, 30).Value = ""
End If
'Erhöhe counter "a" um 1
'Ende der For Schleife
Next a
End With
End Sub
Der Bereich unter 'Drucken funktioniert einwandfrei jedoch der Bereich zum 'Speichern gibt zur Zeit gar nichts aus, nichtmal eine Fehlermeldung.
Kann mit jemand erklären was ich falsch gemacht habe bzw wie es richtig geht?