Débogage Macro: Absence de commande

Option Explicit

Sub AfficherDelais(ByVal ligneRes As Integer, ByVal delai As Single)
    Dim dateLiv As Date, today As Date
    Dim retard As Single
    today = Date
    If ligneRes > 0 Then
    With shSynthese
        dateLiv = CDate(.Cells(ligneRes, 18))
       retard = CInt((today - dateLiv + delai) * 10) / 10
        delai = CInt(10 * delai) / 10
       .Cells(ligneRes, 27) = delai & " jrs"
        
        If retard > 0 Then
            .Cells(ligneRes, 28).Value = retard & " jrs"
            .Cells(ligneRes, 28).Font.Color = RGB(255, 0, 0)
        End If
    
        .Range("R" & ligneRes & ":AB" & ligneRes).Borders(xlEdgeTop).LineStyle = xlDash
    End With    'shSynthese
    End If
End Sub
Function GetInfosCC(ByRef CC As String, ByVal tpsRestant As Single, ByRef tpsAttente As Single) As Single
    Dim ligne As Integer
    
    ligne = 1
    
    With shCC
        'TQ on a pas trouvé le centre de charge mais qu'il reste des lignes
        While .Cells(ligne, 1).Value <> CC And .Cells(ligne, 1).Value <> ""
            ligne = ligne + 1
        Wend    'Fin TQ on a pas trouvé le centre de charge
        
        'Si on a trouvé le centre de charge
        If .Cells(ligne, 1).Value = CC Then
            tpsAttente = .Cells(ligne, 3)
            
            'Si on a pas de capacité (sous-traitance)
            If .Cells(ligne, 8) = "" Then
                GetInfosCC = 0
            Else
                GetInfosCC = tpsRestant / .Cells(ligne, 8)
            End If  'Fin si on a pas de capacité
        Else
            tpsAttente = 0
            GetInfosCC = 0
        End If  'Fin si on a trouvé le centre de charge
    End With    'shCC
End Function

Private Sub CheckChk()
    If chkCC.Value = True And chkCommandes.Value = True And chkOA.Value = True And chkOF.Value = True And chkOFMontage.Value = True Then
        chkTout.Value = True
    ElseIf chkCC.Value = False And chkCommandes.Value = False And chkOA.Value = False And chkOF.Value = False And chkOFMontage.Value = False Then
        chkTout.Value = False
    Else
        chkTout.Value = Null
    End If
End Sub

Private Sub chkCC_Click()
    Call CheckChk
End Sub
Private Sub chkCommandes_Click()
    Call CheckChk
End Sub
Private Sub chkOA_Click()
   Call CheckChk
End Sub
Private Sub chkOF_Click()
    Call CheckChk
End Sub
Private Sub chkOFMontage_Click()
    Call CheckChk
End Sub

Private Sub chkTout_Click()
    Dim etat As Boolean
    
    etat = chkTout.Value
    
    chkCC.Value = etat
    chkCommandes.Value = etat
    chkOA.Value = etat
    chkOF.Value = etat
    chkOFMontage = etat

End Sub

Function CopyOA(projet, article, ByVal ligneRes As Integer, OA As Integer)

    Dim lastTop(5)
    
    Dim res As Range
    Dim firstAddress As String
    
    Dim ligneOA As Long
    Dim colOA As Integer
    
    
    'nb d'OA correspondants à la commande
    OA = 0
    
    'Application.ScreenUpdating = False
    
    With shOA
        Set res = .Range("B:B").Find(What:=article, LookIn:=xlFormulas, LookAt _
            :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
            :=False, SearchFormat:=False)
    
        If Not res Is Nothing Then
            firstAddress = res.Address
            Do
                ligneOA = res.Row
        
                If .Cells(ligneOA, 1) = projet And res.Value = article Then
                    For colOA = 3 To 7
                        If OA = 0 Or .Cells(ligneOA, colOA).Value <> lastTop(colOA - 2) Then
                            shSynthese.Cells(ligneRes, colOA + 26).Value = .Cells(ligneOA, colOA).Value
                            lastTop(colOA - 2) = .Cells(ligneOA, colOA).Value
                        End If
                        
                    Next colOA
                    
                    OA = OA + 1
                    ligneRes = ligneRes + 1
                End If
                Set res = .Range("B:B").FindNext(After:=res)
            Loop While Not res Is Nothing And res.Address <> firstAddress
        End If
    End With    'shOA
    
    If OA > 0 Then
        With shSynthese.Range("AC" & ligneRes - OA & ":AG" & ligneRes - 1)
            'bordure épaisse :
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
            .Borders(xlEdgeTop).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
        
            'couleur de cellules : blanc
            .Interior.Color = RGB(255, 255, 255)
        End With    'shSynthese.Range("AC" & ligneRes - oa & ":AG" & ligneRes - 1)
    End If
End Function

Function CopyOF(projet, article, ByVal ligneRes As Integer, of As Integer)

    Dim lastTop(14)
    Dim nbTabOF As Integer
    
    Dim res As Range
    Dim delai As Single, tpsAttente As Single, capacite As Single
    
    Dim firstAddress As String
    Dim ligneDebut As Long, ligneOF As Long
    Dim colOF As Integer
    

    
    'nb d'OF correspondants à la commande
    of = 0
    ligneDebut = 0
    
    
    With shOF
        Set res = .Range("B:B").Find(What:=article, LookIn:=xlFormulas, LookAt _
            :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
            :=False, SearchFormat:=False)
    
        If Not res Is Nothing Then
            firstAddress = res.Address
            Do
                ligneOF = res.Row
                
                'Si la ligne d'OF correspond
                If .Cells(ligneOF, 1) = projet And res.Value = article Then
                
                    'Si même OF
                    If .Cells(ligneOF, 4) = lastTop(2) Then
                        delai = delai + tpsAttente      'Ajout du temps d'attente précédent
                        delai = delai + GetInfosCC(.Cells(ligneOF, 8), .Cells(ligneOF, 10) - .Cells(ligneOF, 11), tpsAttente)
                    
                        For colOF = 3 To 11
                            'Si un nouvel OF
                            If colOF > 7 Or of = 0 Or .Cells(ligneOF, colOF).Value <> lastTop(colOF - 2) Then
                                shSynthese.Cells(ligneRes, colOF + 15).Value = .Cells(ligneOF, colOF).Value
                                lastTop(colOF - 2) = .Cells(ligneOF, colOF).Value
                                
                                'On enregistre l'OF
                                ReDim tabOF(nbTabOF + 1)
                                tabOF(nbTabOF) = .Cells(ligneOF, 4).Value
                                nbTabOF = nbTabOF + 1
                            End If  'Fin si un nouvel OF
                        Next colOF
                    Else
                        For colOF = 3 To 11
                            'On réaffiche toutes les informations
                            shSynthese.Cells(ligneRes, colOF + 15).Value = .Cells(ligneOF, colOF).Value
                            lastTop(colOF - 2) = .Cells(ligneOF, colOF).Value
                            
                            'On enregistre l'OF
                            ReDim tabOF(nbTabOF + 1)
                            tabOF(nbTabOF) = .Cells(ligneOF, 4).Value
                            nbTabOF = nbTabOF + 1
                            'Fin si un nouvel OF
                        Next colOF
                        
                        
                        'Si on a déjà fait un OF avant :
                        If ligneDebut <> 0 Then
                            Call AfficherDelais(ligneDebut, delai)
                        End If  'Fin si on a déjà fait un OF avant
                        
                        ligneDebut = ligneRes
                        delai = GetInfosCC(.Cells(ligneOF, 8), .Cells(ligneOF, 10) - .Cells(ligneOF, 11), tpsAttente)
                    End If  'Fin si même OF
                    
                    'Si sous-traitance
                    If .Cells(ligneOF, 12) <> "" Then
                        For colOF = 12 To 16
                            If of = 0 Or .Cells(ligneOF, colOF).Value <> lastTop(colOF - 2) Then
                                shSynthese.Cells(ligneRes, colOF + 17).Value = .Cells(ligneOF, colOF).Value
                                lastTop(colOF - 2) = .Cells(ligneOF, colOF).Value
                            End If
                        Next colOF
                        shSynthese.Range("AC" & ligneRes & ":AG" & ligneRes).Interior.Color = RGB(255, 255, 255)
                    End If
                    
                    of = of + 1
                    ligneRes = ligneRes + 1
                End If
                Set res = .Range("B:B").FindNext(After:=res)
            Loop While Not res Is Nothing And res.Address <> firstAddress
            
            'Affichage du délai et du retard
            Call AfficherDelais(ligneDebut, delai)
        End If
    End With    'shOF
    If of > 0 Then
        With shSynthese.Range("R" & ligneRes - of & ":AB" & ligneRes - 1)
            'bordure épaisse :
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
            .Borders(xlEdgeTop).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
            
            'couleur de cellules : blanc
            .Interior.Color = RGB(255, 255, 255)
        End With 'shSynthese.Range("R" & ligneRes - of & ":AB" & ligneRes - 1)
    End If
    shSynthese.Activate
End Function
Function CheckOFMontage(ByRef article As String, ByRef dateDebut As Date, ByRef dateFin As Date) As Integer
    Dim besoin As Integer
    Dim res As Range
    Dim firstAddress As String
    Dim ligne As Long
    
    besoin = 0
    
    With shOFMontage
        Set res = .Range("B:B").Find(What:=article, LookIn:=xlFormulas, LookAt _
            :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
            :=False, SearchFormat:=False)
    
        If Not res Is Nothing Then
            firstAddress = res.Address
            Do
                ligne = res.Row
                
                'Les ventes sont prioritaires
                If .Cells(ligne, 3) >= dateDebut And .Cells(ligne, 3) < dateFin Then
                    besoin = besoin + .Cells(ligne, 8)
                    dateDebut = .Cells(ligne, 3)
                End If
            
                Set res = .Range("B:B").FindNext(After:=res)
            Loop While Not res Is Nothing And res.Address <> firstAddress
        End If
    End With    'shOFMontage
    CheckOFMontage = besoin
End Function
'Renvoie Vrai si les stocks ne sont pas suffisants pour honorer la commande
Function CheckStocks(ByRef restants() As QteStock, ByRef nbLus As Integer, ByVal article As String, ByVal besoin As Integer, ByVal stock, ByVal ladate As Date) As Long
    Dim i As Integer
    i = 1
    While i <= nbLus And restants(i).article <> article
        i = i + 1
    Wend
    
    'si on a déjà lu l'article recherché
    If i <= nbLus Then
        restants(i).stock = restants(i).stock - besoin
    'sinon, on lit l'article pour la première fois
    Else
        'ajout de l'article
        restants(i).stock = stock - besoin
        restants(i).article = article
        restants(i).dateBesoin = CDate("1 / 1 / 1900")
        nbLus = nbLus + 1
    End If
    
    restants(i).stock = restants(i).stock - CheckOFMontage(article, restants(i).dateBesoin, ladate)
    restants(i).dateBesoin = ladate
    
    'les stocks suffisent-ils à satisfaire la commande en cours ?
    CheckStocks = restants(i).stock
End Function

Private Sub CleanImports()
    shCommande.Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    shOF.Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    shOA.Range("A:IV").Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    
    shCommande.Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    shOF.Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    shOA.Range("A:IV").Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
End Sub
Private Sub MakeSynthese()
    Dim restants() As QteStock      'tableau du stock restant pour chaque article lu
    Dim articlesLus As Integer       'nombre d'articles lus
    Dim stockTheo As Long
    
    Dim nbOF As Integer
    Dim nbOA As Integer
    
    Dim ligneRes As Long, ligneCmd As Long
    Dim col As Integer
    
    Dim ensemble As String, projet As String, article As String
    Dim lastEnsemble As String, lastProjet As String, lastArticle As String
    
    
    ReDim restants(shCommande.Range("A:A").End(xlDown).Row)
    With shSynthese
        .Activate
        With .Range("A:IV")
            'Effacement des bordures sur la feuille
            .Borders.LineStyle = xlLineStyleNone
            
            'couleur de cellules : gris
            .Interior.Pattern = xlPatternNone
            .Interior.Color = RGB(192, 192, 192)
            .ClearContents
            .Font.Color = RGB(0, 0, 0)
            .Font.Bold = False
        End With    '.Range ("A:IV")
        
        .Range("A1:AG1") = Array("Date", "Cde", "Client", "Nom", "Lg", "Projet", "Code article", "Description", "Qté cdée", "A livrer", _
                                    "Code article", "Description", "Besoin", "Sto phy", "Sto cde", "Sto rés", "Sto théo", "Livr", "OF", "Qté plan", " Qté réal", "Opé", " CC", "Description", "Tps all", " Temps pass", "Délai", "Retard", _
                                    "N° ordre", "Fourn", "pos", "Qté rest", "Récept")
        .Range("A1:AG1").Font.Bold = True
        .Range("A1:J1").Interior.Color = RGB(0, 0, 255)
        .Range("A1:J1").Font.Color = RGB(255, 255, 255)
        .Range("K1:Q1").Interior.Color = RGB(255, 255, 128)
        .Range("R1:AB1").Interior.Color = RGB(255, 192, 128)
        .Range("AC1:AG1").Interior.Color = RGB(192, 255, 128)
        
        Call AnnulerFusionCellules
        
        
    End With
    
    'nb de ligne ds la feuille finale
    ligneRes = 2
    ensemble = "aaaaaaaaaaaaaaaaa"
    projet = "aaaaaaaaaaaaaaaaaaa"
    article = ""
    'Pour chaque commande
    
    articlesLus = 0 'on n'a détecté aucun article
    ligneCmd = 6    '1ère ligne du carnet de commandes à prendre en compte
    
    With shSynthese
        
        While shCommande.Cells(ligneCmd, 1) <> ""
            'ligneRes = ligneRes + 1
            
            lastEnsemble = ensemble
            lastProjet = projet
            lastArticle = article
            
            ensemble = shCommande.Cells(ligneCmd, 7)
            projet = shCommande.Cells(ligneCmd, 6)
            article = shCommande.Cells(ligneCmd, 12)
                
            'si la ligne correspond à un nouvel article on l'affiche
            If ensemble <> lastEnsemble Or projet <> lastProjet And (projet <> "" Or lastProjet <> "") Then
                'Si ni OA ni OF pour l'article précédent trouvés
                If .Cells(ligneRes, 1) <> "" Then
                    'si la pièce est prête
                    If .Cells(ligneRes, 17) = "" Then
                        With .Range("A" & ligneRes & ":Q" & ligneRes)
                            If .Cells(1, 9).Value = .Cells(1, 10).Value Then
                                .Interior.Color = RGB(192, 255, 128)   'ligne sans OF ni OA en vert
                            Else
                                .Interior.Color = RGB(255, 255, 0)   'gestion des reliquats en jaune
                                shSynthese.Range("K" & ligneRes & ":Q" & ligneRes).Merge
                                .Cells(1, 11).Value = "En attente de décision (confirmation des reliquats)"
                            End If
                            
                            .Font.Bold = True
                        End With
                    End If
                        
                    ligneRes = ligneRes + 1     'saut de ligne pour ne pas écraser l'ensemble vide
                End If
                For col = 1 To 10
                    .Cells(ligneRes, col).Value = shCommande.Cells(ligneCmd, col).Value
                Next col
                'bordure épaisse :
                .Range("A" & ligneRes & ":AG" & ligneRes).Borders(xlEdgeTop).Weight = xlThick
            End If
            
    
            If article <> "" Then
                'si le stock ne suffit pas
                stockTheo = CheckStocks(restants, articlesLus, article, shCommande.Cells(ligneCmd, 14).Value, shCommande.Cells(ligneCmd, 15).Value, CDate(shCommande.Cells(ligneCmd, 1).Value))
                If stockTheo < 0 Then
                    .Cells(ligneRes, 17).Value = stockTheo
                    Call CopyOF(projet, article, ligneRes, nbOF)
                    Call CopyOA(projet, article, ligneRes, nbOA)
    
                    If article <> lastArticle Or ensemble <> lastEnsemble Then
                        .Cells(ligneRes, 11) = article
                    End If
                    'quantités (à livrer, stock, en commande, en réserve
                    For col = 13 To 17
                        .Cells(ligneRes, col - 1).Value = shCommande.Cells(ligneCmd, col).Value
                    Next col
                    
                    If (nbOA > nbOF) Then nbOF = nbOA
                    If (nbOF > 0) Then
                        .Range("A" & ligneRes & ":Q" & ligneRes + nbOF - 1).Interior.Color = RGB(255, 255, 255)
                        ligneRes = ligneRes + nbOF
                    Else
                        With .Range("A" & ligneRes & ":Q" & ligneRes)
                            .Font.Color = RGB(255, 255, 255)
                            .Font.Bold = True
                            .Interior.Color = RGB(192, 0, 0)
                            .Interior.Pattern = xlPatternGray8
                        End With
                        ligneRes = ligneRes + 1
                    End If
                'sinon, le stock suffit
                Else
                                
                End If
            End If
            ligneCmd = ligneCmd + 1
        Wend
        
        If nbOF > 0 Then
        '    ligneRes = ligneRes - 1
        End If
        
        If ensemble = lastEnsemble And .Cells(ligneRes, 1) = "" Then
            ligneRes = ligneRes - 1
        Else
            'éventuellement la dernière ligne est un ensemble vide, auquel cas on la colore en vert
            If .Cells(ligneRes, 17) = "" Then
                With .Range("A" & ligneRes & ":Q" & ligneRes)
                    .Interior.Color = RGB(192, 255, 128)   'ligne sans OF ni OA en vert
                    .Font.Bold = True
                End With
            End If
        End If
        
        .Range("A2:AG" & ligneRes).Borders(xlInsideVertical).Weight = xlThin
    End With
    
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$AG$" & ligneRes
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&""Arial,Gras""&14CARNET DE COMMANDES ET MANQUANTS" _
                        & " du " & shCommande.Range("C3").Value & " au " & shCommande.Range("C4").Value _
                        & Chr(10) & "Horizon des OF et OA: " & shOF.Range("C2").Value
                        
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = "Page &P de &N"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.354330708661417)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 70
        .PrintErrors = xlPrintErrorsDisplayed
    End With
End Sub
Private Sub ResetForm(feuille As Worksheet)
    feuille.Range("A:IV").ClearContents
End Sub
Private Sub cmdReset_Click()
    If chkCC.Value = True Then Call ResetForm(shCC)
    If chkCommandes.Value = True Then Call ResetForm(shCommande)
    If chkOA.Value = True Then Call ResetForm(shOA)
    If chkOF.Value = True Then Call ResetForm(shOF)
    If chkOFMontage.Value = True Then Call ResetForm(shOFMontage)
End Sub

Private Sub cmdSyntheseDateClient_Click()

   'Suppression des commentaires AG 31:0:713
   Worksheets("Synthese").Columns("S:S").ClearComments
   
   
   'pour eviter de ralentir, on affiche les modifs seulement à la fin
    Application.ScreenUpdating = False
    
    Call CleanImports
    
    shCommande.Activate
    Rows("6:6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("G6"), Order1:=xlAscending, _
                    Key2:=Range("E6"), Order2:=xlAscending, _
                    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
    Selection.Sort Key1:=Range("A6"), Order1:=xlAscending, _
                    Key2:=Range("C6"), Order2:=xlAscending, _
                    Key3:=Range("B6"), Order3:=xlAscending, _
                    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
    Call MakeSynthese
    
End Sub


Private Sub cmdSyntheseDateCommande_Click()
    

   'Suppression des commentaires AG 31:0:713
   Worksheets("Synthese").Columns("S:S").ClearComments
       
    
    'pour eviter de ralentir, on affiche les modifs seulement à la fin
    Application.ScreenUpdating = False
    
    Call CleanImports
    
    shCommande.Activate
    Rows("6:6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("A6"), Order1:=xlAscending, _
                    Key2:=Range("B6"), Order2:=xlAscending, _
                    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
    Call MakeSynthese
End Sub


Private Sub MultiPage1_Change()

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = True
    
    If Height < 50 Then
        Height = 227
    Else
        Height = 5
    End If
End Sub

Sub AnnulerFusionCellules()
    Columns("A:AG").Select
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub