Code abändern statt Drucken, PDF erstellen

Private Sub cmdOK_Click()
Dim lngI As Long, lngNext As Long, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
With Sheets("Listbox1")
For lngI = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(lngI) Then
If rng1 Is Nothing Then
Set rng1 = .Cells(lngI + 1, 1)
Else
Set rng1 = Union(rng1, .Cells(lngI + 1, 1))
End If
End If
Next
End With
With Sheets("Listbox2")
For lngI = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(lngI) Then
If rng2 Is Nothing Then
Set rng2 = .Cells(lngI + 1, 1)
Else
Set rng2 = Union(rng2, .Cells(lngI + 1, 1))
End If
End If
Next
End With
With Sheets("Listbox3")
For lngI = 0 To ListBox3.ListCount - 1
If ListBox3.Selected(lngI) Then
If rng3 Is Nothing Then
Set rng3 = .Cells(lngI + 1, 1)
Else
Set rng3 = Union(rng3, .Cells(lngI + 1, 1))
End If
End If
Next
End With
With Sheets("Listbox4")
For lngI = 0 To ListBox4.ListCount - 1
If ListBox4.Selected(lngI) Then
If rng4 Is Nothing Then
Set rng4 = .Cells(lngI + 1, 1)
Else
Set rng4 = Union(rng4, .Cells(lngI + 1, 1))
End If
End If
Next
End With
With Sheets("Fahrzeugbegleitkarte")
If Not rng1 Is Nothing Then rng1.Copy .Cells(14, 2)
lngNext = Application.Max(11, .Cells(.Rows.Count, 2).End(xlUp).Row + 1)
If Not rng2 Is Nothing Then rng2.Copy .Cells(lngNext, 2)
lngNext = Application.Max(11, .Cells(.Rows.Count, 2).End(xlUp).Row + 1)
If Not rng3 Is Nothing Then rng3.Copy .Cells(lngNext, 2)
lngNext = Application.Max(11, .Cells(.Rows.Count, 2).End(xlUp).Row + 1)
If Not rng4 Is Nothing Then rng4.Copy .Cells(lngNext, 2)
Unload Me
End With
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
Worksheets("Fahrzeugbegleitkarte").Range("B7:B109").Font.Name = "Tahoma"
Worksheets("Fahrzeugbegleitkarte").Range("B7:B109").Font.Size = 12
Worksheets("Fahrzeugbegleitkarte").Range("B7:B109").Font.FontStyle = "Italic"
Worksheets("Fahrzeugbegleitkarte").Range("B7:B109").VerticalAlignment = xlCenter
Worksheets("Fahrzeugbegleitkarte").Range("B7:B109").WrapText = True
Sheets("Fahrzeugbegleitkarte").Activate
Range("A13:C109").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Dim LoI As Long                                 ' Schleifenvariable
Dim LoLetzte As Long                            ' Variable für letzte Zeile
' letzte Zeile unabhängig von Excelversion für Spalte I (9)
LoLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), _
Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
For LoI = LoLetzte To 2 Step -1
If Cells(LoI, 1)  Empty Then Exit For
Next LoI
' Druckbereich festlegen
ActiveSheet.PageSetup.PrintArea = "$A$1:$C$" & LoI
ActiveSheet.PrintOut
End Sub