AW: mehrfach kopieren bereich untereinander, Print
27.01.2020 13:39:02
Piet
Hallo Hans
ich habe es mal umgeschrieben für untereinander drucken. Hoffe das es einwandfrei laeuft. Muste eine Fehlermeldung mit dem letzten Befehl abfangen, vor Next AC! - Dort kannst du auch EZei = EZei + xx die Anzahl der Leerzeilen zwischen den Etiketts selbst einstellen, oder auf Null stellen. Ich hoffe das es gut klappt, konnte nicht viel testen. Toi, toi, toi ...
mfg Piet
'umgeschrieben für Endlos Etikettdrucker
Sub Kopieren_Print_untereinander()
Dim AC As Range, EZei As Long
Dim EGB As Worksheet, lz1 As Long
Dim Anzahl As Integer, j As Integer
Dim rngVor As Range, rngR As Range
Dim lngZ As Long, lngS As Long, ii As Long
Set EGB = Sheets("Eingabe")
lz1 = EGB.Cells(100, 2).End(xlUp).Row
Sheets("Etikett_print").UsedRange.EntireRow.Delete
Application.ScreenUpdating = False
'Eingabe in Hifsspalten kopieren + sortieren
EGB.Range("B4:D" & lz1).Copy
EGB.Range("P4").PasteSpecial xlPasteValues
EGB.Range("G4:H" & lz1).Copy
EGB.Range("S4").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Alle Eingaben Ohne "X" löschen
For Each AC In EGB.Range("O4:O" & lz1)
If UCase(AC.Offset(0, 3)) "X" Then _
AC.Resize(1, 7).ClearContents
Next AC
'Eingabe in Hifsspalten sortieren
EGB.Range("P4:T" & lz1).Sort Key1:=EGB.Range("Q4"), Order1:=xlDescending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
On Error GoTo Fehler
'Schkeife zum ausfüllen von "Etikett_print"
For Each AC In EGB.Range("P4:P" & lz1)
Anzahl = AC.Cells(1, 2).Value
With Sheets("Layout_etikett")
'VBA Etikett ausfüllen
.Range("A10").Value = AC.Cells(1, 1)
.Range("A12").Value = AC.Cells(1, 4)
.Range("B13").Value = AC.Cells(1, 5)
'VBA Etikett Bereich festlegen
Set rngVor = .Range("A10:B14")
lngS = rngVor.Columns.Count
lngZ = rngVor.Rows.Count * Anzahl
End With
'VBA Etikett ğber Spalten Offset ausfüllen
With Sheets("Etikett_print").Range("A1").Offset(EZei, 0).Resize(lngZ, lngS)
rngVor.Copy ' kopieren
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
.Cells.Interior.ColorIndex = xlNone
Application.CutCopyMode = False
For lngZ = 1 To rngVor.Rows.Count ' Zeilenhöhen
Set rngR = .Rows(lngZ)
For ii = 0 To Anzahl - 1
.Cells((ii * 5) + 5, 1).Value = ii + 1 'Zä _
hler
Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count))
Next ii
rngR.RowHeight = rngVor.Rows(lngZ).RowHeight
Next lngZ
End With
EZei = Sheets("Etikett_print").Cells(Rows.Count, 1).End(xlUp).Row
EZei = EZei + 1 'Anzahl Leerzeilen zwischen Etiketts
'** Unbedingter Aussprung, sonst laeuft Makro in Fehlermeldung!!
If AC.Cells(2, 1).Value = "" Then Exit For
Next AC
'** Daten zum Testen nicht löschen!'!
' Worksheets("eingabe").Range("B4:H12").Value = ""
Worksheets("Etikett_print").PrintOut Copies:=1, Collate:=True
Application.ScreenUpdating = True
Exit Sub
Fehler: MsgBox "unerwarteter Fehler: " & vbLf & Error()
End Sub