AW: letzter Versuch
29.06.2021 22:08:42
Daniel
Hallo Rolf
Erstmal vielen, vielen Dank für Deine kostbare Zeit, welche Du für mich genommen hast. Ich hatte auch noch etwas Zeit investiert. Das wäre mein Ziel, wie es eigentlich am Schluss aussehen sollte. Denke ein Profi, so wie Du, kann den Code sicherlich kürzer und besser schreiben?
Vielleicht hilfst Du mir noch ein letztes Mal und kannst diesen Code noch verfeinern?
Was meinst Du?
Lieben Gruss aus der Schweiz
Daniel
Dim i As Long
Dim ws As Worksheet
Set ws = Worksheets("Lagerliste_drucken")
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then Exit For
Next
If i = .ListCount Then
MsgBox "Bitte Auswahl treffen"
Exit Sub
End If
ws.Select
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
Suchen = strAusgabe & .List(i)
Set Rng = Worksheets("WSCAR_Daten").Range("F:F").Find(Suchen, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Rng Is Nothing Then
MsgBox "Lagerort " & Suchen & " nicht gefunden!", vbInformation
.Selected(i) = False
Else
.Selected(i) = False
Überschriften_Einfügen Suchen
sfirstaddress = Rng.Address
Do
Rng.Offset(0, -5).Resize(1, 5).Copy Destination:=Worksheets("Lagerliste_Drucken").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
If Cells(Rows.Count, 1).End(xlUp).Row = 49 Then
MsgBox "Zeile erreicht"
ws.HPageBreaks.Add before:=Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1)
Überschriften_Einfügen Suchen
End If
If Cells(Rows.Count, 1).End(xlUp).Row = 98 Then
MsgBox "Zeile erreicht"
ws.HPageBreaks.Add before:=Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1)
Überschriften_Einfügen Suchen
End If
If Cells(Rows.Count, 1).End(xlUp).Row = 147 Then
MsgBox "Zeile erreicht"
ws.HPageBreaks.Add before:=Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1)
Überschriften_Einfügen Suchen
End If
If Cells(Rows.Count, 1).End(xlUp).Row = 196 Then
MsgBox "Zeile erreicht"
ws.HPageBreaks.Add before:=Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1)
Überschriften_Einfügen Suchen
End If
Set Rng = Worksheets("WSCAR_Daten").Range("F:F").FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address sfirstaddress
End If
End If
Next i
End With