Office: VBA Zeilen Einzeldruck nach Filter

Ich drucke ein Tab. Blatt schwarz/weiß in Hochformat mit festgelegten Kopf Fußzeilen mit den Spalten H:Q, nach meinem Makro PrintBefore klappt das.

Folgenden Code, der nur eine Zeile (H35:Q35) pro Seite druckt, möchte ich anpassen, dass nur Zeilen >0 oder <>0 aus dem Formelergebnis in Spalte "J" ab Zeile 35 gedruckt werden:

Code:

Sub DruckenProZeile()
    Dim lngZ As Long, lngLZ As Long
    
    lngLZ = Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile der Spalte J ermitteln
    
    If MsgBox("Sollen jetzt alle Zeilen EINZELN gedruckt werden ?", _
        vbYesNo + vbQuestion) = vbYes Then
        For lngZ = 35 To 40 'Alle Zeilen ab Zeile 35
            Rows("35:" & lngLZ).Hidden = True 'Zuerst ALLE Zeilen ab Zeile 35 ausblenden
            Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden
            ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
        Next
    End If

    Rows("35:" & lngLZ).Hidden = False 'ALLE Zeilen ab Zeile 35 wieder einblenden
End Sub

Ich versuche schon seit Tagen ihn mit einem Filter anzupassen. Im Moment wird jede Zeile (For lngZ = 35 To 40) 'Alle Zeilen ab Zeile 35 bis 40 gedruckt.
In Spalte "J" sind ab Zeile 35 Formeln . Es sollen Seiten gedruckt werden mit Zeile (H35:Q35) wenn in Spalte "J" das Formelergebnis >0 ist. Darüber der Bereich (H1:Q34) soll auf jeder Seite mitgedruckt werden.

Kann mir bitte jemand einen Tipp geben?
Vielen Dank im voraus

 

Hi,

versuche es mal so:

Code:

If Cells(lngZ, 10) > 0 then
    Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden 
    ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
End If

Bis später,
Karin

 

Vielen Dank

Hallo Karin,

ich bin begeistert, vielen Dank. Nach einfügen von "End If" macht es alles wie es sollte. Hier nochmal der Code (auskommentiert):

Code:

Sub DruckenProZeile()
    Dim lngZ As Long, lngLZ As Long
    
    lngLZ = Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile der Spalte J ermitteln
    
    If MsgBox("Sollen jetzt alle Zeilen EINZELN gedruckt werden ?", _
        vbYesNo + vbQuestion) = vbYes Then
        For lngZ = 35 To 534 'Alle Zeilen ab Zeile 35
            Rows("35:" & lngLZ).Hidden = True 'Zuerst ALLE Zeilen ab Zeile 35 ausblenden
        If Cells(lngZ, 10) > 0 Then
            Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden wenn in "H" >0
            ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
        End If
        Next
        End If
    Rows("35:" & lngLZ).Hidden = False 'ALLE Zeilen ab Zeile 35 wieder einblenden
End Sub

Wäre das noch auf Schnelligkeit zu optimieren, da ich natürlich bis zu 500 Zeilen prüfe?

Viele Grüße nach Sachsen aus Thüringen
luckybaby

 

Hi,

versuche es mal am Anfang deines Codes mit Application.ScreenUpdating = False und am Ende Application.ScreenUpdating = True.

Bis später,
Karin

 

Hallo Karin,

vielen Dank für die schnelle Antwort - sende gleich Kaffee und Kuchen nach Sachsen...

luckybaby

 

2 Makros kombinieren - Hilfe

Ich habe hier den Code von 2 Makros, die ich gern in einem Modul eines Arbeitsblattes zusammen wirksam machen möchte. Beide funktionieren für sich, jedoch schaffe ich es nicht sie zu kombinieren.

1. Code von SmartTools, nimmt einen benannten Tabellenbereich, erstellt daraus ein temporäres Bild und fügt dieses in der Fußzeile ein:

Code:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim oFooterTextSheet As Worksheet
Dim oFooterRange As Range
Dim sPicName As String
Dim sTmpFolder As String
Dim arrSheetNames() As String
Dim i As Long
Dim oTmpChart As ChartObject
Dim oSelectedSheet As Worksheet

  Set oFooterTextSheet = _
      ActiveWorkbook.Worksheets("TABELLE")
  Set oFooterRange = _
      oFooterTextSheet.Range("S2:AA21")
  sPicName = "Fuss.png"
  sTmpFolder = Environ("TEMP") & "\"

  i = 0
  ReDim arrSheetNames _
      (ActiveWorkbook.Windows(1) _
       .SelectedSheets.Count - 1)
  For Each oSelectedSheet In _
      ActiveWorkbook.Windows(1).SelectedSheets
    arrSheetNames(i) = oSelectedSheet.Name
    i = i + 1
  Next oSelectedSheet

  oFooterTextSheet.Select
  oFooterRange.CopyPicture xlPrinter
  Set oTmpChart = oFooterTextSheet.ChartObjects _
      .Add(0, 0, _
       oFooterRange.Width + 10, _
       oFooterRange.Height + 10)
  With oTmpChart
    .Chart.Paste
    .Chart.ChartArea.Border.LineStyle = 0
    .ShapeRange.Line.Visible = msoFalse
    .Chart.Export sTmpFolder & sPicName
    .Delete
  End With
  For i = 0 To UBound(arrSheetNames)
    With ActiveWorkbook _
        .Sheets(arrSheetNames(i)).PageSetup
      .LeftFooter = "&G"
      .LeftFooterPicture.Filename = _
          sTmpFolder & sPicName
    End With
  Next
  ActiveWorkbook.Sheets(arrSheetNames()).Select
  Set oSelectedSheet = Nothing
  Set oTmpChart = Nothing
  Set oFooterRange = Nothing
  Set oFooterTextSheet = Nothing
End Sub

2. Code mit Hilfe von Beverly, setzt oben Zeilen 1 bis 34, filtert ab Zeile 35 nach Spalte "J" ungleich Null und druckt für diese Einzelzeilen je ein Blatt aus.

Code:

Sub DruckEinzeln()
    Dim lngZ As Long, lngLZ As Long
    Application.ScreenUpdating = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$34"
        .PrintTitleColumns = ""
    End With
    lngLZ = Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile der Spalte J ermitteln
    
    If MsgBox("Sollen jetzt alle ZEILEN EINZELN gedruckt werden ?", _
        vbYesNo + vbQuestion) = vbYes Then
        Rows("35:" & lngLZ).AutoFilter Field:=10, Criteria1:="<For> 0 Then 'Zellen in Spalte "J" >0
            Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden
            ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
        End If
        Next
        End If
        Rows("35:" & lngLZ).AutoFilter Field:=10
    Rows("35:" & lngLZ).Hidden = False 'ALLE Zeilen ab Zeile 35 wieder einblenden
        Application.ScreenUpdating = True
End Sub

Mein Ziel:
Beide Codes so verbinden, dass ich sie in einem Modul per Aufruf nutzen kann und unter der Einzelzeile die Fußzeile aus dem 1. Code mit erscheint. Kann mir jemand bitte helfen?

Viele Grüße
luckybaby

 

Hi,

ich habe deinen 1. Code jetzt nicht getestet, aber generell sollte er doch automatisch ausgeführt werden, sobald du den 2. Code ausführst und zur Zeile ActiveSheet.PrintOut kommst.

Bis später,
Karin

 

Leider nein - Ich habe den 1. Code z.B. kurz vor der Zeile mit Printout eingefügt. Die Dim Regeln natürlich oben darüber. Es wird immer nur der Einzeldruck Code ausgeführt ohne diesen 1. für die Fußzeile.

Evtl. eine Idee?
Grüße nach Freiberg

luckybaby

 

Hi,

schreibe den folgenden Code in ein allgemeines Modul:

Code:

Sub Fusszeile()
    Dim chDiagramm As ChartObject
    Application.ScreenUpdating = False
    With Worksheets("TABELLE")
        .Range("S2:AA21").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
        Set chDiagramm = .ChartObjects.Add(0, 0, .Range("S2:AA21").Width + 10, .Range("S2:AA21").Height + 10)
        With chDiagramm.Chart
            .Paste
            .ChartArea.Border.LineStyle = 0
            .Parent.ShapeRange.Line.Visible = msoFalse
            .Export Filename:=Environ("TEMP") & "\Fuss.png", FilterName:="png"
        End With
        chDiagramm.Delete
    End With
    With ActiveSheet.PageSetup
      .LeftFooter = "&G"
      .LeftFooterPicture.Filename = Environ("TEMP") & "\Fuss.png"
    End With
    Kill Environ("TEMP") & "\Fuss.png"
    Set chDiagramm = Nothing
    Application.ScreenUpdating = True
End Sub

und füge im 2. Code vor die Druckzeile ein:

Code:

            Fusszeile

und lösche den gesamten Code im Workbook_BeforePrint.

Dein 2. Code ist fehlerhaft in Zeile Rows("35:" & lngLZ).AutoFilter..., außerdem gibt es ein Next ohne For.

Bis später,
Karin

 

Danke Beverly

Hallo Karin,
Danke für Deine Arbeit, bin gerade am testen. Die Fußzeile klappt ja hervorragend. Der ursprüngliche Code war im letzten Newsletter von Smarttools und viel aufwendiger - allen Respekt vor Deinen VBA Kenntnissen.
Die Fehler im 2. Code, der diesen Einzeldruck generiert habe ich noch nicht finden können, d.h. wenn ich das next und ein End if im unteren Bereich weg nehme läuft es nicht mehr.
Der zweite Code sieht im Mom so aus:

Code:

Sub DruckEinzeln()
    Dim lngZ As Long, lngLZ As Long
    Application.ScreenUpdating = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$34"
        .PrintTitleColumns = ""
    End With
    lngLZ = Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile der Spalte J ermitteln
    
    If MsgBox("Sollen jetzt alle MITARBEITER EINZELN gedruckt werden ?", _
        vbYesNo + vbQuestion) = vbYes Then
        Rows("35:" & lngLZ).AutoFilter Field:=10, Criteria1:="<For> 0 Then 'Zellen in Spalte "J" >0
            Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden
            Fusszeile
            ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
        End If
        Next
        End If

    'ABGESCHALTET Rows("35:" & lngLZ).AutoFilter Field:=10 'Jetzt mal deaktiviert und geht trotzdem - Danke

    Rows("35:" & lngLZ).Hidden = False 'ALLE Zeilen ab Zeile 35 wieder einblenden
        Application.ScreenUpdating = True
End Sub

Der Code läuft sehr langsam ab, flackert auch trotz 'Application.ScreenUpdating'. Bei jeder einzelnen Zeilen Filterung z.B. 4 Seiten (Filterung in Spalte J ungleich Null) flackern - trotzdem bis hier her alles richtig, kann man dann im Blatt sehen, wie Zeile für Zeile bis 234 abgearbeitet wird (Zeile für Zeile wird geflackert). Danach wird dann auch die ganze Ansicht ohne Filterung wiederhergestellt, jedoch sind die Zeilen Nummern ab Zeile 35 blau dargestellt, wegen der Filterung?

Schönen Sonntag liebe Karin. Vielleicht kann ich auch einmal mit ein paar anderen Tipps etwas Gutes tun. Dazu kann ich mich ja mal per PM melden.
luckybaby

 

Hi,

wenn ich deinen Code - so wie er ist - in ein allgemeines Modul kopiere, dann wird die Zeile

Code:

Rows("35:" & lngLZ).AutoFilter Field:=10, Criteria1:="<For> 0 Then 'Zellen in Spalte "J" >0 

Rot dargestellt, folglich ist daran etwas falsch (ich nehme an da fehlt ein " am Ende vor dem Kommentar und For in eckigen Klammern ist wohl auch nicht korrekt, das Then gehört dort auch nicht hin).

Weiterhin wird die Zeile

Code:

        Next

beim Kompilieren des Codes vom Debugger blau markiert und der Hinweis ausgegeben "Fehler beim Kompilieren, Next ohne For".

Dass der Code langsam läuft ist eigentlich logisch, denn, wenn der Code in einer Schleife ablaufen sollte, der Autofilter immer wieder neu gesetzt wird - und das braucht einfach Zeit. Auch müsste das Bild in die Fußzeile nicht bei jedem Schleifendurchlauf eingefügt werden, das reicht dann vor dem Schleifendurchlauf. Aber da der Code derzeit nicht korrekt hier dargestellt wird, war/ist nicht ersichtlich, dass das Ganze in einer Schleife abgearbeitet werden soll.
Man könnte eventuell auch eine andere Lösung finden, die möglicherweise schneller ist, aber wenn man die Arbeitsmappe nicht kennt, kann man da schlecht etwas dazu sagen.

Bis später,
Karin

 

Für mich sieht's so aus, als wenn "[ ] HTML in diesem Beitrag deaktivieren" nicht angehakt wurde. Denn das "For" hinter dem "Criteria" paßt da irgewndwie nicht hin, als wenn da was verschluckt wurde. Es wäre aber das passende "For" zum angemeckerten "Next"...

Gruß, Michael

 

Danke Michael, das stimmt... Hier der richtige Code:

Code:

Sub DruckEinzeln()
    Dim lngZ As Long, lngLZ As Long
    Application.ScreenUpdating = False
     Worksheets("PRÄMIEN").Unprotect Password:="test"
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$34"
        .PrintTitleColumns = ""
    End With
    lngLZ = Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile der Spalte J ermitteln
        If MsgBox("Sollen jetzt alle ZEILEN EINZELN gedruckt werden ?", _
        vbYesNo + vbQuestion) = vbYes Then
        Rows("35:" & lngLZ).AutoFilter Field:=10, Criteria1:="<>"
        For lngZ = 35 To 234 'Alle Zeilen ab Zeile 35 bis 234
            Rows("35:" & lngLZ).Hidden = True 'Zuerst ALLE Zeilen ab Zeile 35 ausblenden
        If Cells(lngZ, 10) > 0 Then 'Zellen in Spalte "J" >0
            Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden
            Fusszeile
            ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
        End If
        Next
        End If
        Rows("35:" & lngLZ).AutoFilter Field:=10
    Rows("35:" & lngLZ).Hidden = False 'ALLE Zeilen ab Zeile 35 wieder einblenden
        'Hier wird der Blattschutz wieder gesetzt
    Worksheets("PRÄMIEN").Protect UserInterfaceOnly:=True, Password:="test"
        Application.ScreenUpdating = True
End Sub

Ich werde mal noch etwas probieren und eine Beispieldatei vorbereiten. Danke für Eure Aufmerksamkeit und Hilfe. Die 'Fusszeile' von Beverly funktioniert prima in Kombination. Ich habe nur noch vor Ausführung die Aufhebung und anschl. Setzung des Blattschutzes gemacht. Der Unterschied ist nur, dass es ziemlich langsam geworden ist bei der Abarbeitung/Filterung der Zeilen bis 234. Vorher (ohne den Fusszeilen Modul) hat der Code bei z.B. 4 Zeilen <> 0 in Spalte J von Zeile 35 bis 234 vier Mal je die Seite zum Drucker geschickt. Jetzt in Kombination mit Fusszeile sieht man wie jede Zeile abgearbeitet werden, das dauert ziemlich lange.

luckybaby

 

Ähm... bist Du sicher, daß Du in jedem Schleifendurchlauf den Ausdruck starten willst?

Ich schätze, die zwei Zeilen sollten eher direkt hinter das "Next"...

Gruß, Michael

 

Hi,

ich hatte ja schon geschrieben:

Die Codezeile für das Aufrufen des Makros Fusszeile musst du also vor die For...Next Schleife und nicht in die Schleife schreiben (so wie es jetzt der Fall ist), denn dann wird sie ja bei jedem Schleifendurchlauf ausgeführt - es sei denn, es soll jedes mal ein anderer Inhalt dargestellt werden.

Weiterhin hatte ich geschrieben:

Auf jeden Fall wäre es hilfreich wenn du deine Arbeitsmappe hochlädst, denn ohne jegliche Kenntnis der Bedingungen irgendetwas zu programmieren ist nicht sinnvoll.

Bis später,
Karin