AW: VBA Druck
11.02.2017 15:43:20
Andi
Hallo Mumpel,
ja ich Drucke per VBA- die Datei ist leider zu groß - trotz das ich alles Unwichtige entfernt habe.
ABER ich hab bestimmt den Fehler gefunden.
Hier erst mal das Druckmakro- Das funktioniert Top.
kurze Erläuterung: Tabelle "Bearbeiten ist mit Daten im Bereich von A-L nach unten bis zu 3000 Zeilen gefüllt.
Dann habe ich ein Startblatt- und ein Endblatt- es wird nach Zeilenabfrage die Anzahl der zu druckenden Blätter bestimmt, und es wird dann in die richtigen Blätter gedruckt.
Die "Bearbeiten Daten" sind dort in den Zeilen mit Rahmen Formatiert und diese werden auch so in die " Start_End-Blätter" übertragen.
Entferne ich die Rahmen Formatierung ( im Blatt Bearbeiten), dann werden die 3000 Zeilen ganz schnell übertragen.
Dann fehlen aber auch die Zeilen Rahmen in der fertigen gedruckten Datei.
Abhilfe: Kann man im Druckcode eine Veränderung vornehmen- so das nur Zellinhalte ( A-L ) von "Bearbeiten" K O P I E R T werden und in "Start und Endblatt" nur Zellinhalte ohne Formatierung E I N G E F Ü G T werden?
Die Zeilenformatierung ist ja schon in den Start-End Druckblätter hinterlegt- und darf nicht mit gelöscht werden.
Kann mal jemand drüberschauen?
Option Explicit
Const Druck = "Druckmenü" ' hier als Konstante zum einfachen Ändern
Sub D_In_Blatt_Drucken()
'Bildschirmaktivitäten deaktivieren
Application.ScreenUpdating = False
Dim s&, vS&, bS&, ZpS& ' Seite, von .. bis Seite, Zeilen pro Seite
Dim MBl&, Zm&, r& 'letzte MB, Zeilen max., Rest
Dim rB As Range ' Bereich im Blatt "Bearbeiten"
Dim mitKopie As Boolean ' gibt es noch Zeilen für das Endblatt?
Dim inTB As String, shTB As Worksheet
Dim zkZ& ' zu kopierende Zeilen (Anzahl); evtl. auf 50, 51? Im Druckmenü: O12
Const AzeE = 19 ' Abstand zum ersten Eintrag im Start- bzw. Endblatt, also 1+19=20
Dim zNrn&() ' Array für Zeilennummern
Dim Grafik As Shape
With Sheets(Druck)
vS = 1 ' immer ab Seite 1
bS = .Range("q10") ' nicht das "eingegebene" bis, sondern "Seiten eff."
ZpS = .Range("o8")
Zm = .Range("o6")
r = .Range("q8") ' Rest
inTB = .Range("o11")
zkZ = .Range("o12")
End With
If ZpS + AzeE > zkZ Then MsgBox "Abstand + Zeilen pro Seite > als zu kopierende Zeilen.": Exit _
Sub
' Ermitteln, ob inTB existiert
On Error Resume Next
Sheets(inTB).Activate
Application.DisplayAlerts = False ' wegen Meldung beim Löschen...
If Err.Number = 0 Then Sheets(inTB).Delete ' wenn es da ist, löschen
Application.DisplayAlerts = True
Err.Clear
On Error GoTo 0
' die folgenden Zeilen sind eigentlich ein programmiertechnisch unnützer Umweg,
' aber so ist wahrscheinlich einfacher nachvollziehbar, was die Formel macht.
' Ich definiere ein Array mit zwei Spalten, das die Zeilennummer zum Einfügen
' des Formulars (Spalte 1) und die Zeilennummer zum Einfügen der Werte (Spalte 2)
' enthält:
ReDim zNrn(1 To bS + 1, 1 To 2) ' bs + 1: bs*Startblatt + Endblatt
For s = 1 To bS + 1
zNrn(s, 1) = 1 + (s - 1) * zkZ ' ergibt bei zkz=49: 1, 50, ...
zNrn(s, 2) = zNrn(s, 1) + AzeE ' ergibt bei AzeE=19: 20, 69, ...
Next
Application.ScreenUpdating = False
' zuerst das Formular kopieren
Sheets("Startblatt").Range("A20:L49").ClearContents
' evlt. vorhandene Daten müssen nicht mitkopiert werden
' einmal die SPALTEN kopieren - dann passen die Spaltenbreiten
' Sheets("Startblatt").Columns("A:M").Copy shTB.Range("A1")
' For Each Grafik In shTB.Shapes: Grafik.Delete: Next
Sheets("Startblatt").Copy before:=Sheets(1)
Set shTB = ActiveSheet
shTB.Name = inTB
' dann die ZEILEN...
Sheets("Startblatt").Rows("1:" & zkZ).Copy
With shTB
For s = vS + 1 To bS ' + 1
.Paste Destination:=.Cells(zNrn(s, 1), 1)
.Range("K" & zNrn(s, 1) + 7) = s
Next
End With
Set rB = Sheets("Bearbeiten").Range("A1:L" & ZpS)
With shTB
For s = vS To bS
rB.Offset((s - 1) * ZpS).Copy .Cells(zNrn(s, 2), 1)
Next
End With
' nach Ablauf der Schleife hat s den Wert bS+1, also 1 mehr als eigentlich erwartet
If Zm > (s - 1) * ZpS Then
Set rB = rB.Offset((s - 1) * ZpS).Resize(r)
mitKopie = True
Else
mitKopie = False
End If
With Sheets("Endblatt")
.Range("A20:L30").ClearContents
.Rows("1:" & zkZ).Copy shTB.Cells(zNrn(s, 1), 1)
End With
If mitKopie Then rB.Copy shTB.Cells(zNrn(s, 2), 1)
shTB.Range("K" & zNrn(s, 1) + 7) = s
MsgBox "fertig"
End Sub
Sub D_zeilen()
Dim z&
With Sheets("Bearbeiten")
z = .Range("C" & .Rows.Count).End(xlUp).Row
End With
With Sheets(Druck)
.Range("O6") = z
.Range("t8") = .Range("q10")
.Range("s8") = 1
.Range("t9") = 0
End With
End Sub
Sub D_Drucken()
Dim MBn&, s&, vS&, bS&, ZpS& ' MBnach, Seite, von .. bis Seite, Zeilen pro Seite
Dim MBl&, Zm&, r& 'letzte MB, Zeilen max., Rest
Dim rB As Range ' Bereich im Blatt "Bearbeiten"
Dim mitKopie As Boolean ' gibt es noch Zeilen für das Endblatt?
With Sheets(Druck)
MBn = .Range("t6")
vS = .Range("s8")
bS = .Range("t8")
ZpS = .Range("o8")
Zm = .Range("o6")
r = .Range("q8")
End With
Set rB = Sheets("Bearbeiten").Range("A1:L" & ZpS)
With Sheets(Druck)
MBl = vS - 1
For s = vS To bS
rB.Offset((s - 1) * ZpS).Copy .Range("A20")
.Range("t9") = s: .Range("k8") = s
.PrintPreview
If s - MBl >= MBn And MBl (s - 1) * ZpS Then
Set rB = rB.Offset((s - 1) * ZpS).Resize(r)
mitKopie = True
Else
mitKopie = False
End If
With Sheets("Endblatt")
.Range("A20:L30").ClearContents
If mitKopie Then rB.Copy .Range("A20")
.Range("k8") = s
.PrintPreview
End With
End Sub