Hallo Stefan,
ich hab auch mal eine leicht optinmierte Fassung des ursprünglich von mir erstelltem Makros erstellt.
Es findet noch eine zusätzliche Prüfung der Min-/Max-Längen der jeweils noch nicht zugewiesenen Abschnittslängen statt.
Das Makro probiert dann ob es günstiger ist, 2 oder mehr kurze Stücke aus der Restlänge zuzuschneiden, statt eines langen Stücks.
Gruß
Franz
Sub Berechnen()
Application.ScreenUpdating = False
Dim wksBer As Worksheet
Dim wksVor As Worksheet
Dim wksRohrList As Worksheet
Dim EndeList As Long
Dim ZeileIter As Long
Dim dblLaengeMax As Double, dblLaengeMin As Double
Dim dblLaengeRohr As Double, dblLaengeSchnitt As Double, dblLaengeRest As Double, _
dblBreiteSchnitt As Double
Dim Zeile As Long, NrRohr As Long, ZeileBer As Long, ZeileLetzte As Long, ZeileVorletzte As _
Long
Set wksBer = ActiveWorkbook.Worksheets("Berechnung")
Set wksVor = ActiveWorkbook.Worksheets("Vorgabe")
'Vorgabewerte einlesen
With wksVor
dblLaengeRohr = .Range("C2").Value
dblBreiteSchnitt = .Range("C3").Value
End With
With wksBer
'prüfen, ob Rohrlängen in Spalte A eingetragen sind
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile < 2 Then
MsgBox "Keine Daten für Rohrlängen vorhanden!"
Exit Sub
End If
'Daten im Berechnungsbereich löschen
ZeileBer = .Cells(.Rows.Count, 5).End(xlUp).Row
If ZeileBer > 2 Then
.Range(.Cells(3, 5), .Cells(ZeileBer, 7)).ClearContents
End If
'ggf. vorhandene Einträge für Rohrnummer und Verschnitt löschen
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row
If Zeile >= 2 Then
.Range(.Cells(2, 2), .Cells(Zeile, 3)).ClearContents
Else
' MsgBox "Keine Daten für Rohrlängen AAA vorhanden!"
' Exit Sub
End If
'Daten in Berechnungsbreich übernehmen
ZeileBer = 2
For Zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
ZeileBer = ZeileBer + 1
.Cells(ZeileBer, 5).Value = Zeile
.Cells(ZeileBer, 6).Value = .Cells(Zeile, 1).Value
Next
'Rohrlängen im Berechnungsbereich absteigend sortieren
With .Range(.Cells(2, 5), .Cells(ZeileBer, 7))
.Sort key1:=.Range("B1"), order1:=xlDescending, Header:=xlYes
End With
Do
NrRohr = NrRohr + 1
dblLaengeRest = dblLaengeRohr
ZeileIter = 3
ZeileLetzte = 0
'nächste Iteraration
Iteration:
For Zeile = ZeileIter To ZeileBer
If IsEmpty(.Cells(Zeile, 7)) Then
dblLaengeSchnitt = .Cells(Zeile, 6)
dblLaengeMax = fncLaengeMax
dblLaengeMin = fncLaengeMin
Select Case dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
Case Is < 0
'do nothing
Case Is >= dblLaengeMax
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
Case Is >= dblLaengeMin
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
Case Is <= 100 'Minimal tolerierter Verschnitt
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
Exit For
Case Else
Select Case dblLaengeRest
Case Is >= dblLaengeMin + dblLaengeMax + dblBreiteSchnitt
If dblLaengeMax = dblLaengeSchnitt Then
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
End If
Case Is >= 2 * dblLaengeMin + dblBreiteSchnitt
If dblLaengeMin = dblLaengeSchnitt Then
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
End If
Case Is >= dblLaengeMax
If dblLaengeMax = dblLaengeSchnitt Then
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
End If
Case Is >= dblLaengeMin
If dblLaengeMin = dblLaengeSchnitt Then
dblLaengeRest = dblLaengeRest - dblLaengeSchnitt - dblBreiteSchnitt
.Cells(Zeile, 7) = NrRohr
ZeileVorletzte = Zeile
ZeileLetzte = .Cells(Zeile, 5) 'Zeile des Schnitts merken
End If
Case Is < dblLaengeMin
ZeileIter = ZeileVorletzte + 1
'.Cells(ZeileVorletzte, 7).ClearContents
ZeileVorletzte = ZeileVorletzte + 1
GoTo Iteration
End Select
End Select
End If
Next
.Cells(ZeileLetzte, 3).Value = dblLaengeRest
'Prüfen, ob für alle Rohrschnitte eine Rohr-Nr. eingetragen ist
If Application.WorksheetFunction.CountBlank(.Range(.Cells(2, 7), _
.Cells(ZeileBer, 7))) = 0 Then Exit Do
Loop
'Berechnungsbereich nach Zeile sortieren
With .Range(.Cells(2, 5), .Cells(ZeileBer, 7))
.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
End With
'Ergebnis kopieren
.Range(.Cells(3, 7), .Cells(ZeileBer, 7)).Copy
.Cells(2, 2).PasteSpecial Paste:=xlPasteValues
'Berechnungsbereich nach Nummer-Rohr sortieren
With .Range(.Cells(2, 5), .Cells(ZeileBer, 7))
.Sort key1:=.Range("C1"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
Function fncLaengeMax() As Double
Dim wksBer As Worksheet
Dim dblLaengeMax As Double
Dim Zeile As Long
Set wksBer = ActiveWorkbook.Worksheets("Berechnung")
dblLaengeMax = 0
With wksBer
For Zeile = 3 To .Cells(.Rows.Count, 5).End(xlUp).Row
If .Cells(Zeile, 7) = "" Then
If .Cells(Zeile, 6) > dblLaengeMax Then
dblLaengeMax = .Cells(Zeile, 6)
End If
End If
Next
End With
fncLaengeMax = dblLaengeMax
End Function
Function fncLaengeMin() As Double
Dim wksBer As Worksheet
Dim dblLaengeMin As Double
Dim Zeile As Long
Set wksBer = ActiveWorkbook.Worksheets("Berechnung")
dblLaengeMin = 50000
With wksBer
For Zeile = 3 To .Cells(.Rows.Count, 5).End(xlUp).Row
If .Cells(Zeile, 7) = "" Then
If .Cells(Zeile, 6) < dblLaengeMin Then
dblLaengeMin = .Cells(Zeile, 6)
End If
End If
Next
End With
fncLaengeMin = dblLaengeMin
End Function