Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
25.04.2024 21:21:16
Zellkommentar in UserForm anzeigen und bearbeiten
25.04.2024 21:13:13
Kalenderwochen addieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1536to1540
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1536to1540
1536to1540
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Reiter löschen, speichern ohne Makro

Reiter löschen, speichern ohne Makro
20.01.2017 10:58:36
Beermann
Ich bin gestern angefangen mich in VBA einzulesen und da hat sich dieses Forum als sehr hilfreich erwiesen.
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?

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Reiter löschen, speichern ohne Makro
20.01.2017 13:40:26
Michael
Hi,
ich gehe davon aus (vielleicht fälschlicherweise), daß Du effektiv nur das Blatt "Prüfprotokoll" speichern möchtest.
Ich habe das Makro mit ein paar "With" etwas übersichtlicher gemacht und ein "Array" eingeführt: auf die Art werden nur *einmal* Daten aus "Messungen" eingelesen, was schneller rennt.
An zwei Stellen (mit ***** gekennzeichnet) habe ich für meine Tests Änderungen vorgenommen, a) damit ich die Druckvorschau anstelle anstelle eines Ausdrucks erhalte und b) damit das Blatt unter einem bei mir vorhandenen Pfad gespeichert wird. Das mußt Du wieder anpassen: 
Public Sub SeriendruckNeu()
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" 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))
''    Warum Ende?
''    'Ende der Abfrage zur Berücksichtigung einer Zeile
''    End If
''    'Drucken
''    If CStr(arr(a, 26)) = "x" Then
'       ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
.PrintPreview ' *****
'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))
' zum Testen woanders hin... *****
strdname = ThisWorkbook.Path & "\" & "Beermann_" & _
CStr(arr(a, 4))
MsgBox "Speichern unter... " & strdname
'speichern
.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" Then
End If
'Erhöhe counter "a" um 1
'Ende der For Schleife
Next a
End With
' wozu eigentlich löschen, wenn sie eh wieder überschrieben werden?
' wenn, dann genügt es NACH der Schleife (dem Next) zum "Zurücksetzen"
' des Formulars
.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 Sub
.copy übernimmt das (gedanklich vor dem . angegebene Blatt, siehe WITH) in eine neue, leere Datei - die muß nur noch gespeichert und wieder geschlossen werden.
Wenn Du den Button auf das Blatt "Messungen" setzt, mußt Du ihn nicht extra löschen...
Schöne Grüße,
Michael
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige