Das Problem ist, dass die Schleife entweder nur einmal durchlaufen wird, wenn s=0 ist, oder dass es von der LooP-Schleife zuvor übernommen wird und riesen groß wird.
Hier der Quelltext von dieser Funktion.
Private Sub anlegen_Click()
Dim lz As Long, i As Long, dat As Date, s 'wieviel tage brauche ich für die aufträge bis termin' _
dat = CDate(termin)
With ActiveSheet
lz = .Cells(Rows.Count, 2).End(xlUp).Row 'letzte beschriebene Zeile ermitteln**
For i = 5 To lz 'beginne bei Zeile 5'
If .Cells(i, 2) 5 Then
NoWeekD = NoWeekD + 1
End If
Next i
t = ((D2 - D1 + 1) - NoWeekD)
If s "" Then
artikelnummer = WorksheetFunction.Proper(artikelnummer.Value)
With Worksheets("datenbank").Columns(1)
Set rZelle = .Find(artikelnummer.Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
ThisWorkbook.Sheets("siebdruck").Cells(5, 16) = .Cells(rZelle.Row, 5). _
Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 1) = auftragsdatum.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 2) = termin.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 3) = produktbezeichnung.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 4) = artikelnummer.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 5) = auftragsgröße.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 7) = nutzen.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 11) = bemerkung.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 6) = anzahl.Value
Else
ThisWorkbook.Sheets("siebdruck").Cells(5, 17) = "x"
ThisWorkbook.Sheets("siebdruck").Cells(5, 1) = auftragsdatum.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 2) = termin.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 3) = produktbezeichnung.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 4) = artikelnummer.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 5) = auftragsgröße.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 7) = nutzen.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 11) = bemerkung.Value
ThisWorkbook.Sheets("siebdruck").Cells(5, 6) = anzahl.Value
End If
End With
End If
If Auftrag_anlegen_SB.cu.Value = True Then
ThisWorkbook.Sheets("siebdruck").Cells(5, 9) = "CU"
End If
If Auftrag_anlegen_SB.ff.Value = True Then
ThisWorkbook.Sheets("siebdruck").Cells(5, 9) = "FF"
End If
If Auftrag_anlegen_SB.cu.Value = True Then
ThisWorkbook.Sheets("siebdruck").Cells(5, 17) = ""
End If
If Auftrag_anlegen_SB.cu.Value = True Then
ThisWorkbook.Sheets("siebdruck").Cells(5, 16) = ""
End If
If Auftrag_anlegen_SB.cu.Value = True Then
ThisWorkbook.Sheets("siebdruck").Cells(5, 18).FormulaR1C1 = "=ROUNDUP((RC[-13]/RC[- _
11])*1.02,0)"
End If
If Auftrag_anlegen_SB.ff.Value = True Then
ThisWorkbook.Sheets("siebdruck").Cells(5, 18).FormulaR1C1 = "=ROUNDUP(((RC[-13]/RC[- _
11])+RC[-12])*1.02,0)"
End If
If (Auftrag_anlegen_SB.cu.Value = False) And (Auftrag_anlegen_SB.ff.Value = False) _
Then
MsgBox "Kupfer oder Frontfolie markieren"
auftragsdatum.SetFocus
Exit Sub
End If
'Hier gehts weiter'
Else
u = D2 'Datum aus textbox'
Do
u = u + 1
NoWeekD = 0
With ActiveSheet
lz = .Cells(Rows.Count, 2).End(xlUp).Row 'letzte beschriebene Zeile ermitteln**
For i = 5 To lz 'beginne bei Zeile 5'
If .Cells(i, 2) 5 Then 'Wochenendtage ermitteln'
NoWeekD = NoWeekD + 1
End If
Next i
t = ((u - D1 + 1) - NoWeekD) ' Anzahl Arbeitstage zwischen heute und möglichem Termin _
ermitteln'
Loop While Not s