XL 2019 Optimisation de longueur de barre en long multiple

' 
' Decouli simple
Dim K1 As Integer, K2 As Integer, K3 As Integer, K4 As Integer, N As Integer, K As Integer
Dim TVAL(1000) As Long, TQ(1000) As Long, TLib(1000) As String     ' dim 1000
Dim TSol(1000) As Long    ' Solution pour la barre étudiée      ' Dim 1000
Dim TNoeud(1000) As Integer ' N° de ligne du Noeud étudié
Dim TTOT(1000) As Long    ' Longueur Totale jusqu'à ce Noeud
Dim TAux(100) As Long     ' tableau de valeurs auxiliaires      ' dim 100
Dim NomFeuille As String, AERR As String
Dim ChuteAcceptable As Long, LongueurBarres As Long, Morceau As Long, TOTAL As Long, CHUTE As Long
Dim A1 As Variant, LigneBas As Integer

Sub Découpe2()



' Macro enregistrée le 11/01/2002 par Jean DUPRAT, Aménagée le 08/03/12
' 1°) Préparation des données
' 2°) Trouver une bonne solution
'  Les différentes solutions sont considérées comme
'       les Noeuds d'une arborescence
'       dont on examine toutes les branches.

    Mess0 = "Découpe Linéaire": MessF = "Travail Terminé"
    On Error GoTo NIVERR

' =============================================================
' 1°) Préparation des données et Constantes
    K1 = 1  ' colonne des dimensions
    K2 = 2  ' colonne des quantités par dimension
    K3 = 3  ' colonne des libellés
    K4 = 5  ' colonne des paramètres
Sheets("demande2").Activate
' 1-1) Contrôle des données
    NomFeuille = ActiveSheet.Name
    If Cells(1, K1) < "A" Then GoTo NIVERR1
    LigneDébut = 2: A1 = Cells(LigneDébut, K1)
    If IsNumeric(A1) = False Then GoTo NIVERR1
    LongueurBarres = Cells(2, K4)
    If LongueurBarres = 0 Then GoTo NIVERR1
    ChuteAcceptable = Cells(3, K4)
    If ChuteAcceptable > LongueurBarres / 2 Then GoTo NIVERR1
    
'1-2) Report dans la feuille Travail
    KK = 9   ' colonne cumuls. ATTENTION modifier aussi dans Report( )
    
' Lecture des données
    N = 1
NIV1:
    N = N + 1: Morceau = Cells(N, K1): If Morceau = 0 Then GoTo NIV12
    If Morceau > LongueurBarres Then GoTo NIVERR4
    If N > 1000 Then GoTo NIVERR2
    Q = Cells(N, K2): If Q < 1 Then Q = 1
    TVAL(N) = Morceau: TQ(N) = Q: TLib(N) = Cells(N, K3)
    GoTo NIV1
NIV12:
    LigneBas = N - 1
    For N = LigneBas + 1 To 1000                         ' sécurité
        TVAL(N) = Empty: TQ(N) = Empty: TLib(N) = Empty
        TVAL(N) = Morceau: TQ(N) = Q: TLib(N) = Cells(N, K3)
        Next N

' report dans la feuille Travail
    Sheets("Travail2").Activate
    Cells(4, KK + 7) = "Recherche en cours"
    Cells(6, KK + 7) = NomFeuille
    
    Columns("A:B").Activate: Selection.ClearContents
    Range("A1").Value = Sheets(NomFeuille).Range("A1").Value
    Range("B1").Value = Sheets(NomFeuille).Range("C1").Value
    
    LigneFin = 1
    For N = 2 To LigneBas: Morceau = TVAL(N)
        If LigneFin > 1000 Then GoTo NIVERR3
        For K = 1 To TQ(N): LigneFin = LigneFin + 1
            Cells(LigneFin, 1) = Morceau
            If K = 1 Then Cells(LigneFin, 2) = TLib(N)
            If K <> 1 Then Cells(LigneFin, 2) = TLib(N)
            Next K
        Next N
    Cells(2, KK + 6) = LigneFin - LigneDébut + 1
    
'1-3) Tri
    Columns("A:B").Activate
    Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Contrôle sur la plus petite dimension demandée
    If ChuteAcceptable > Cells(LigneFin, 1) Then GoTo NIVERR1
'1-4) on double la colonne A dans la colonne K
    Columns("A:B").Copy
    Columns("K:L").Activate
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Cells(1, 11) = ""
    Cells(1, 12) = ""
    
'1-5) Vidage de l'ancienne solution, colonnes C-D-E-F
    Range("C1:I1").Activate
    Selection.Cut Destination:=Range("AC1:AH1")
    Columns("C:I").Activate
    Selection.ClearContents
    Range("AC1:AI1").Activate
    Selection.Cut Destination:=Range("C1:I1")
    NombreBarres = 0: Cells(3, KK + 6) = NombreBarres
    
'1-6) tableaux de travail
     TAux(1) = 0  'Nombre de solutions testées par barre
     TAux(2) = 0  'Nbre de solutions améliorées
     TAux(3) = LigneFin * LigneFin  ' Limitateur de bouclage
    If LigneFin > 50 Then TAux(3) = 4 * LigneFin
    LigneReport = 1         ' ligne de report des résultats
    Cells(5, KK + 6) = TAux(1)        ' Nombre de solutions

' ============================================================
' 2°) C'est parti !
    
' essai du sous-programme Report()
'    TSol(1) = 2: TSol(2) = 4
'    Call Report(TSol, 2, LigneReport, NombreBarres, LongueurBarres, LigneFin, TAux)
   
' début du suivi de l'arborescence
NIV2:
    AERR = "NIV2:"
    If LigneFin < LigneDébut Then Range("A1").Activate:  GoTo FINI
 
' 2-1) On prend le 1er morceau
    TSol(1) = 2: TAux(1) = TAux(1) + 1

    If LigneFin = LigneDébut Then
        Call Report(TSol, 1, LigneReport, NombreBarres, LongueurBarres, LigneFin, TAux)
        GoTo FINI
        End If
    
    Morceau = Cells(2, 11): DernierMorceau = Cells(LigneFin, 11)
    If Morceau + DernierMorceau > LongueurBarres Then
        Call Report(TSol, 1, LigneReport, NombreBarres, LongueurBarres, LigneFin, TAux)
        GoTo NIV2
        End If
        
' 2-2) On cherche la combinaison qui donnera le moins de chute avec ce morceau
    AERR = "NIV2-2)"
    ligne = LigneDébut: TOTAL = Morceau: AncienneChute = LongueurBarres + 1
    Noeud = 1: TNoeud(1) = ligne: TTOT(1) = TOTAL
    
'    ML = 15   ' pour mise au point
NIV22:
    If ligne >= LigneFin Then GoTo NIV225     ' on est au bout
    TAux(1) = TAux(1) + 1
    ligne = ligne + 1: Morceau = Cells(ligne, 11)
    CHUTE = LongueurBarres - TOTAL - Morceau
    If CHUTE < 0 Then GoTo NIV22
' donc le morceau tient dans la chute
    Noeud = Noeud + 1: TNoeud(Noeud) = ligne
    TOTAL = TOTAL + Morceau: TTOT(Noeud) = TOTAL
    
' pour mise au point
'  ML = ML + 1: For J = 1 To Noeud: Cells(ML, J + 2) = TNoeud(J): Next J
'  Cells(ML, 1) = Taux(1)
  
    If CHUTE >= DernierMorceau Then GoTo NIV22
    
NIV225:
    AERR = "NIV225:"
' sécurité = limitateur de bouclage
    If TAux(1) > TAux(3) Then

        TAux(3) = 2 * TAux(3)
        End If
' fin de la sécurité
    
    TAux(1) = TAux(1) - Noeud + 1
    If CHUTE < 0 Then CHUTE = LongueurBarres - TTOT(Noeud): Indic = 1
    If CHUTE < AncienneChute Then
        For N = 1 To Noeud: TSol(N) = TNoeud(N): Next N
        NoeudSol = Noeud: TAux(2) = TAux(2) + 1
        AncienneChute = CHUTE
        End If
    If CHUTE <= ChuteAcceptable Then
        Call Report(TSol, NoeudSol, LigneReport, NombreBarres, LongueurBarres, LigneFin, TAux)
        GoTo NIV2
        End If
    
' est-on est au bout de cette branche ?
' plus exactement, peut on remplacer le dernier morceau par 2 plus petits
    If ligne < LigneFin - 1 And Morceau > DernierMorceau Then
        Indic = 0: GoTo NIV22
        End If
    If Indic = 1 Then Noeud = Noeud + 1: Indic = 0
    TNoeud(Noeud) = LigneFin

NIV23:
    AERR = "NIV23:"
    If Noeud <= 2 Then GoTo NIV25
    LigneNM1 = TNoeud(Noeud - 1): ligne = TNoeud(Noeud)
    If ligne - LigneNM1 = 1 Then
        Noeud = Noeud - 1: GoTo NIV23
        End If
' Donc, il y a un intervalle, entre les 2 noeuds ...
    Morceau = Cells(LigneNM1, 11)
    If Morceau = Cells(ligne - 1, 11) Then
' ... Mais c'est partout la même valeur
        Noeud = Noeud - 1: GoTo NIV23
        End If
' ... y'a une dimension différente entre les 2 noeuds
' Donc, on la cherche et on continue
    Noeud = Noeud - 2: ligne = LigneNM1
NIV24:
    If Cells(ligne + 1, 11) = Morceau Then ligne = ligne + 1: GoTo NIV24
    TAux(1) = TAux(1) + Noeud
    TOTAL = TTOT(Noeud): GoTo NIV22
    
' On a fini par détecter la meilleure solution, pour ce 1er morceau
NIV25:
    AERR = "NIV25:"
    Call Report(TSol, NoeudSol, LigneReport, NombreBarres, LongueurBarres, LigneFin, TAux)

    GoTo NIV2
    
NIVERR:
    Mess1 = "Anomalie non prévue détectée dans la macro" + Chr$(10) + "Contacter l'auteur"
    MsgBox Mess1, vbOKOnly, Mess0
    GoTo FINAL
NIVERR1:
    MsgBox "Données anormales", vbOKOnly, Mess0
    GoTo FINAL
NIVERR2:
' on vient ici depuis § NIV1:
' si  N > 300            ' on peut augmenter la taille des DIM
    MsgBox "Limite de 300 formats dépassée", vbOKOnly, Mess0
    GoTo FINAL
NIVERR3:
' si LigneFin > 1000    ' on peut augmenter la limite de 1000, mais
                        ' attention au nombre de noeuds
    MsgBox "Limite de 1000 morceaux dépassée", vbOKOnly, Mess0
    GoTo FINAL
NIVERR4:
    Cells(N, 1).Activate
    MsgBox "Morceau > Longueur des Barres", vbOKOnly, Mess0
    GoTo FINAL
FINAL:
    MessF = "Travail non fait"
FINI:
'    ActiveSheet.PageSetup.PrintArea = "$A$1:$F" & LigneReport
    Cells(4, KK + 7) = MessF
 


End Sub
Sub Report(TSol, NoeudFin, LigneReport, NombreBarres, LongueurBarres, LigneFin, TAux)
' reporte la solution d'une barre dans les colonnes Résultat C-D-E

    KC = 3: KD = KC + 1: KE = KC + 2: KF = KC + 3: KG = KC + 4 ' colonnes report
    KK = 9    ' colonne cumuls. Le même que dans Découpe( )
    cumul = 0

    For LL = 1 To NoeudFin
        LigneM = TSol(LL): LongM = Cells(LigneM, 11)
        LigneReport = LigneReport + 1
        Cells(LigneReport, KC) = LongM: cumul = cumul + LongM
        Cells(LigneReport, KD) = Cells(LigneM, 12)
        Next LL
    
    Cells(LigneReport, KE) = cumul                  ' longueur utilisée
    Cells(LigneReport, KF) = LongueurBarres - cumul ' chute
    Cells(LigneReport, KG) = LongueurBarres
    Cells(LigneReport, KG + 1) = TAux(1)
    If TAux(2) > 1 Then Cells(LigneReport, KG + 2) = TAux(2) - 1
    Cells(5, KK + 6) = Cells(5, KK + 6) + TAux(1): TAux(1) = 0: TAux(2) = 0
' suppression des morceaux utilisés de la colonne K
    For LL = NoeudFin To 1 Step -1: LigneM = TSol(LL)
        Range("K" & LigneM).Activate: Selection.Delete shift:=xlUp
        Range("L" & LigneM).Activate: Selection.Delete shift:=xlUp
        LigneFin = LigneFin - 1: TSol(LL) = 0
        Next LL
    
    NombreBarres = NombreBarres + 1: Cells(3, KK + 6) = NombreBarres
    
    
    
End Sub