Plantage sur l'instruction Application.ScreenUpdating = True

juju05

XLDnaute Junior
Bonjour,

Lorsque je lance une macro., je débute par l'instruction:

Code :Sélectionner tout - Visualiser dans une fenêtre à part
Application.ScreenUpdating = false
et je termine par l'instruction
Code :Sélectionner tout - Visualiser dans une fenêtre à part
Application.ScreenUpdating = True
.

Cette dernière instruction est déjà à true lorsqu'elle s'exécute. Cela plante mon programme.

Comment trouver l'origine du problème ?
 

juju05

XLDnaute Junior
Re : Plantage sur l'instruction Application.ScreenUpdating = True

Code:
Option Explicit

Dim gsemaine As Integer
Dim gannee As Integer

Private Sub B_quit_Click()
 UserForm1.Hide
End Sub


Private Sub b_rech_Click()

             
   Dim conn As New ADODB.Connection
   Dim connString
   Dim rsRecords As New ADODB.Recordset
   Dim rsRecord_badg As New ADODB.Recordset
   Dim rsRecord_badg2 As New ADODB.Recordset
   
    Dim affmess As Boolean
   
   Dim rfound As Range
      
    Dim lig As Long
   
   Dim nb_lig, nb_lig_recap, nb_lig_non_aff, nb_lig_recap_stps As Long
   Dim nb_lig_stps, vide, nosem, semaine, annee, num_annee As Long
   
   Dim num_lig_dep, dercol, coldeb, nb_col As Long
   
   Dim nbcol As Integer
      
   Dim sdeb, sfin, adeb, afin, sadeb, safin, lib As String
   
   Dim indicateur(4) As String
   
   Dim type_tps(3)  As String
         
   Dim code, liste_dep, poste As String
   
   Dim ssaammjj, id_res As Long
   
   Dim i, j, k, lalig, ligsec, col, colrecap, colnonaff, colrecstps, colstps  As Integer
   
   Dim trouve, a_traiter, fin_trt, nouvel_op, aucun_badgage As Boolean
   
   Dim nom, prenom, nom_prenom, txtsem, annee_sem, ressource As String
   
   Dim date_traite, datepremjour, date_jour As Date
   
   Dim nb_heure, qte_travaillee As Single
   
   Dim dpt_lu, dpt_traite As String
        
   Dim sh As Range
   
   Dim tableau() As Single
   
   Dim tps_prepa, tps_real, tps_ctrl, tps_total As Single

   Dim nbsem As Integer
   
   Dim nbinfo, nbinforecap, nbinfononaff, nbinforecstps, nbinfostps As Integer
   
   Dim dureecons As Integer
   
   Dim posetoile As Integer
         
   num_lig_dep = 3
   
  If Not IsNumeric(sem.Value) Then
       MsgBox "La semaine saisie n'est pas numérique."
       ann.SetFocus
       Exit Sub
   End If
   
   nosem = CInt(sem.Value)
   
   If nosem < 1 Or nosem > 52 Then
       MsgBox "La semaine saisie doit être comprise entre 1 et 52."
       sem.SetFocus
       Exit Sub
   End If
   
   sem.Value = Format(nosem, "00")
   
   If Not IsNumeric(ann.Value) Then
       MsgBox "L'année saisie n'est pas numérique."
       ann.SetFocus
       Exit Sub
   End If
   
   annee = CInt(ann.Value)
   
   ann.Value = Format(ann.Value, "0000")
      
   semaine = nsem(Date)
   
   num_annee = Format(Now, "yyyy")
   
    If semaine = 1 Then
      num_annee = num_annee - 1
      nosem = 52
   Else
      semaine = semaine - 1
   End If
   
    If ann.Value & sem.Value > num_annee & Format(semaine, "00") Then
      MsgBox "La semaine saisie doit être antérieure à la semaine en cours."
      sem.SetFocus
      Exit Sub
   End If
   
   datepremjour = DateSemaineFR(annee, nosem)
       
   
   connString = "DSN=TOP;Uid=TOPMAN01;Pwd=TOPMAN01"
   conn.Open connString
   
   rsRecords.CursorLocation = adUseServer
   
     Set rsRecords = conn.Execute("select rb.date_start as date_debut from resource_calendar rc inner join resource_calendar_band rb on rb.id_resource_calendar = rc.id_resource_calendar where rc.reference = 'METAL 44' and nvl(rb.type,0) = 6  and rb.date_start <= '" & datepremjour & "' and rb.date_end >= '" & datepremjour + 7 & "'")
   If Not rsRecords.EOF Then
      MsgBox "La semaine demandée correspond à une semaine fermée de l'entreprise."
      sem.SetFocus
      Exit Sub
   End If
   
   rsRecords.Close
   Set rsRecords = Nothing
   
   annee_sem = ann.Value & "-" & sem.Value
   trouve = False
   
   Worksheets("INDIV").Activate
   
    Worksheets("INDIV").Range("A3").Select
   col = 1
   Do Until trouve Or IsEmpty(ActiveCell) = True
     If annee_sem = Cells(3, col).Value Then
        trouve = True
     End If
     col = col + 1
     ActiveCell.Offset(0, 1).Activate
   Loop
   
    If trouve Then
      MsgBox "La semaine demandée a déjà été traitée."
      sem.SetFocus
      Exit Sub
   End If
      
   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   
   date_jour = Date
   
   affmess = False
  
   If affmess Then
      MsgBox "Initialisation de la feuille 'INDIV'."
   End If
      
   nbsem = 52
   
   nbinfo = 2
   
   nbinforecap = 4
   
   nbinfononaff = 3
   
   nbinforecstps = 1
   
   nbinfostps = 2
   
   dureecons = 8
   
   Worksheets("INDIV").Cells.Font.ColorIndex = 1
   
   Worksheets("INDIV").Cells.Font.Bold = False
   
   nb_lig = Worksheets("INDIV").Range("A65536").End(xlUp).Row
   
    nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
   
    nb_lig_recap_stps = Worksheets("RECAP_SANS_TEMPS").Range("A65536").End(xlUp).Row
   
   lib = Trim("TOTAL ENTREPRISE : ")
   
    
   If nb_lig_recap_stps > num_lig_dep Then
   
       Worksheets("RECAP_SANS_TEMPS").Activate
   
           With Worksheets("RECAP_SANS_TEMPS")
          Set rfound = .Range("A4:A" & nb_lig_recap_stps).Find(lib, LookIn:=xlValues, lookat:=xlWhole)
          If Not rfound Is Nothing Then
             lalig = rfound.Row
             Cells(lalig, 1).EntireRow.Delete
             nb_lig_recap_stps = nb_lig_recap_stps - 1
             Set rfound = Nothing
          End If
       End With
   End If
   
   nb_lig_stps = Worksheets("QTE_SANS_TEMPS").Range("A65536").End(xlUp).Row
   
   Worksheets("QTE_SANS_TEMPS").Activate
   
   Worksheets("QTE_SANS_TEMPS").Range("A3").Select
   
   colstps = 1
   Do Until IsEmpty(ActiveCell) = True
      colstps = colstps + 1
      ActiveCell.Offset(0, 1).Activate
   Loop
   
    If colstps > nbinfostps + nbsem Then
      Columns(nbinfostps + 1).Delete
      colstps = colstps - 1
   End If
      
     Cells(3, colstps) = annee_sem
   
     nb_lig_non_aff = Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row
         
   If nb_lig < num_lig_dep Then
      nb_lig = num_lig_dep
   Else
   
     Worksheets("INDIV").Activate
        indicateur(0) = "MOYENNE"
     With Worksheets("INDIV")
          Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(0), LookIn:=xlValues, lookat:=xlWhole)
          If Not rfound Is Nothing Then
             lalig = rfound.Row
             Cells(lalig, 1).EntireRow.Delete
             nb_lig = nb_lig - 1
             Set rfound = Nothing
          End If
     End With
     
     indicateur(1) = "ECART-TYPE"
     With Worksheets("INDIV")
          Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(1), LookIn:=xlValues, lookat:=xlWhole)
          If Not rfound Is Nothing Then
             lalig = rfound.Row
             Cells(lalig, 1).EntireRow.Delete
             nb_lig = nb_lig - 1
             Set rfound = Nothing
          End If
     End With
     
     With Worksheets("INDIV")
          indicateur(2) = "ECART-TYPE/MOYENNE"
          Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(2), LookIn:=xlValues, lookat:=xlWhole)
          If Not rfound Is Nothing Then
             lalig = rfound.Row
             Cells(lalig, 1).EntireRow.Delete
             nb_lig = nb_lig - 1
             Set rfound = Nothing
          End If
     End With
     
     With Worksheets("INDIV")
          indicateur(3) = Trim("NB PERS. N'AYANT PAS BADGEES")
          Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(3), LookIn:=xlValues, lookat:=xlWhole)
          If Not rfound Is Nothing Then
             lalig = rfound.Row
             Cells(lalig, 1).EntireRow.Delete
              nb_lig = nb_lig - 1
             Set rfound = Nothing
          End If
     End With
     
      With Worksheets("INDIV")
          indicateur(4) = Trim("NB PERS. AYANT BADGEES")
          Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(4), LookIn:=xlValues, lookat:=xlWhole)
          If Not rfound Is Nothing Then
             lalig = rfound.Row
             Cells(lalig, 1).EntireRow.Delete
             nb_lig = nb_lig - 1
             Set rfound = Nothing
          End If
     End With
     
   End If   

   nb_lig = Worksheets("INDIV").Range("A65536").End(xlUp).Row
   
   lig = 3  
   
   Worksheets("INDIV").Activate
   If col > nbinfo + nbsem Then
      Columns(nbinfo + 1).Delete
      col = col - 1
   End If
     
   Cells(3, col).Value = ann.Value & "-" & sem.Value
   
   Worksheets("RECAP_SEM").Activate
   
  Worksheets("RECAP_SEM").Cells.Font.ColorIndex = 1
   
   Worksheets("RECAP_SEM").Cells.Font.Bold = False
   
   Worksheets("RECAP_SEM").Range("A3").Select
   colrecap = 1
   Do Until IsEmpty(ActiveCell) = True
     colrecap = colrecap + 1
     ActiveCell.Offset(0, 1).Activate
   Loop
      
   If colrecap > nbinforecap + nbsem Then
      Columns(nbinforecap + 1).Delete
      colrecap = colrecap - 1
   End If
     
  Cells(3, colrecap).Value = ann.Value & "-" & sem.Value
   
  Worksheets("RECAP_SANS_TEMPS").Activate
   
  Worksheets("RECAP_SANS_TEMPS").Range("A3").Select
   
   colrecstps = 1
   Do Until IsEmpty(ActiveCell) = True
      colrecstps = colrecstps + 1
      ActiveCell.Offset(0, 1).Activate
   Loop
   
   If colrecstps > nbinforecstps + nbsem Then
      Columns(nbinforecstps + 1).Delete
      colrecstps = colrecstps - 1
   End If
   
   type_tps(0) = Trim("1.PREPARATION")
   type_tps(1) = Trim("2.REALISATION")
   type_tps(2) = Trim("3.CONTROLE")
   type_tps(3) = Trim("4.NON AFFECTES")
   
   Worksheets("RECAP_NON_AFF").Activate
   
  Worksheets("RECAP_NON_AFF").Cells.Font.ColorIndex = 1
   
   Worksheets("RECAP_NON_AFF").Cells.Font.Bold = False
   
  Worksheets("RECAP_NON_AFF").Range("A3").Select
   
   colnonaff = 1
   Do Until IsEmpty(ActiveCell) = True
     colnonaff = colnonaff + 1
     ActiveCell.Offset(0, 1).Activate
   Loop
   
    If colnonaff > nbinfononaff + nbsem Then
      Columns(nbinfononaff + 1).Delete
      colnonaff = colnonaff - 1
   End If      
   
   dpt_traite = ""
   
   rsRecords.Open " select r.id_resource, r.name, d.name as departement from topmes.resources r inner join toppdm.resource_tree_item rt on  r.id_resource = rt.id_resource inner join topsys.department d on rt.id_parent_origin = d.id_department where r.Type = 1 and upper(r.name) not like '%DISPO%' and d.id_department not in (361,1181,1421,1422)", conn, adOpenForwardOnly, adLockReadOnly
   If conn.State = adStateOpen Then
         rsRecords.MoveFirst
         While Not rsRecords.EOF
              
               a_traiter = True
               nouvel_op = True
               aucun_badgage = False
               
               nom_prenom = Trim(UCase(rsRecords.Fields("name").Value))
               
               posetoile = InStr(rsRecords.Fields("name").Value, "*")
               
               nom_prenom = Replace(nom_prenom, "*", "")
               
               vide = InStr(nom_prenom, " ")
                  
               If vide <> 0 Then
                  prenom = Left(nom_prenom, vide - 1)
                  nom = LTrim(Mid(nom_prenom, vide + 1))
                  nom_prenom = nom & " " & prenom
               Else
                  nom_prenom = LTrim(nom_prenom)
               End If
                   
               With Worksheets("INDIV")
                  Set rfound = .Range("B4:B" & nb_lig).Find(nom_prenom, LookIn:=xlValues, lookat:=xlWhole)
                   If Not rfound Is Nothing Then
                        lalig = rfound.Row
                        Set rfound = Nothing
                        If posetoile > 0 And Left(.Range("A" & lalig).Value, 5) = "zzzz " Then
                            a_traiter = False
                        Else
                            nouvel_op = False
                        End If
                   End If
               End With                             
                            
               If a_traiter Then
               
                  id_res = rsRecords.Fields("id_resource").Value
                  Set rsRecord_badg = conn.Execute("select w.id_wip from topmes.wip w where nvl(w.id_labor_resource,0) = " & id_res & "  and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "'")
                  If rsRecord_badg.EOF Then
                     aucun_badgage = True
                     If posetoile <> 0 And nouvel_op Then
                          a_traiter = False
                     End If
                  Else
                                    Set rsRecord_badg = conn.Execute("select w.id_labor_resource, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl, sum(nvl(w.work_time_hc,0)) as tps_real from topmes.wip w where nvl(w.id_labor_resource,0) = " & id_res & "  and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by w.id_labor_resource")
                     If Not rsRecord_badg.EOF Then
                        tps_prepa = rsRecord_badg("tps_prepa").Value
                        tps_real = rsRecord_badg("tps_real").Value
                        tps_ctrl = rsRecord_badg("tps_ctrl").Value
                        nb_heure = tps_prepa + tps_real + tps_ctrl
                     End If
                  End If
              End If
              
                        If a_traiter Then               
                            If nouvel_op Then
                      nb_lig = nb_lig + 1
                      lalig = nb_lig
                  End If                        
                  dpt_lu = rsRecords.Fields("departement").Value
                  With Worksheets("INDIV")
                        .Range("A" & lalig).Value = dpt_lu
                        .Range("B" & lalig).Value = nom_prenom
                  End With
                  
                  Worksheets("INDIV").Activate
                  
                                  If aucun_badgage Then
                                     If posetoile = 0 Then
                         Cells(lalig, col).Value = 0
                      Else
                                         Cells(lalig, col).Value = ""
                      End If
                  Else
                                      Cells(lalig, col).Value = nb_heure
                  End If
                                                   
                  rsRecord_badg2.Open "select upper(rp.name) as name, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.work_time_hc,0)) as tps_real, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl " _
                  & " from topmes.wip  w inner join toppdm.resources r on w.id_labor_resource = r.id_resource inner join toppdm.resources rp on w.id_resource = rp.id_resource where nvl(w.id_downtime_code,0) = 0 and nvl(w.id_labor_resource,0) = " & id_res & "  and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by rp.name", conn, adOpenForwardOnly, adLockReadOnly
                  If conn.State = adStateOpen Then
                     If Not rsRecord_badg2.EOF Then
                        ' Lecture du premier enregistrement
                        rsRecord_badg2.MoveFirst
                        While Not rsRecord_badg2.EOF
                     
                          tps_prepa = rsRecord_badg2("tps_prepa").Value
                          tps_real = rsRecord_badg2("tps_real").Value
                          tps_ctrl = rsRecord_badg2("tps_ctrl").Value
                          poste = Trim(rsRecord_badg2("name").Value)
                     
                           If tps_prepa <> 0 Then
                        
                                                   trouve = False
                            i = 3
                            Do Until trouve Or i > nb_lig_recap
                               If Worksheets("RECAP_SEM").Range("B" & i) = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i) = poste And Worksheets("RECAP_SEM").Range("D" & i) = type_tps(0) Then
                                  trouve = True
                               End If
                               i = i + 1
                            Loop                            
                             
                          If trouve Then
                               i = i - 1
                            Else
                               nb_lig_recap = nb_lig_recap + 1
                               With Worksheets("RECAP_SEM")
                                  .Range("A" & i) = dpt_lu
                                  .Range("B" & i) = nom_prenom
                                  .Range("C" & i) = poste
                                  .Range("D" & i) = type_tps(0)
                               End With
                            End If
                        
                            Worksheets("RECAP_SEM").Activate
                        
                            Cells(i, colrecap).Value = tps_prepa
                         End If
                     
                         If tps_real <> 0 Or (tps_prepa = 0 And tps_real = 0 And tps_ctrl = 0) Then
                               trouve = False
                               i = 3
                               Do Until trouve Or i > nb_lig_recap
                                  If Worksheets("RECAP_SEM").Range("B" & i) = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i) = poste And Worksheets("RECAP_SEM").Range("D" & i) = type_tps(1) Then
                                     trouve = True
                                  End If
                                  i = i + 1
                               Loop                               

                                If trouve Then
                                  i = i - 1
                               Else
                                  nb_lig_recap = nb_lig_recap + 1
                                  With Worksheets("RECAP_SEM")
                                     .Range("A" & i) = dpt_lu
                                     .Range("B" & i) = nom_prenom
                                     .Range("C" & i) = poste
                                     .Range("D" & i) = type_tps(1)
                                  End With
                               End If
                              
                               Worksheets("RECAP_SEM").Activate
                               
                               Cells(i, colrecap).Value = tps_real
                         End If
                          
                         If tps_ctrl <> 0 Then
                                                     trouve = False
                               i = 3
                               Do Until trouve Or i > nb_lig_recap
                                  If Worksheets("RECAP_SEM").Range("B" & i) = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i) = poste And Worksheets("RECAP_SEM").Range("D" & i) = type_tps(2) Then
                                     trouve = True
                                  End If
                                  i = i + 1
                               Loop
                               
                               If trouve Then
                                  i = i - 1
                               Else
                                  nb_lig_recap = nb_lig_recap + 1
                                  With Worksheets("RECAP_SEM")
                                     .Range("A" & i) = dpt_lu
                                     .Range("B" & i) = nom_prenom
                                     .Range("C" & i) = poste
                                     .Range("D" & i) = type_tps(2)
                                  End With
                               End If
                              
                               Worksheets("RECAP_SEM").Activate
                               
                               Cells(i, colrecap).Value = tps_ctrl
                         End If
                     
                         rsRecord_badg2.MoveNext
                       Wend
                     End If
                  End If
                  rsRecord_badg2.Close
                  Set rsRecord_badg2 = Nothing
                                  
                  Set rsRecord_badg = conn.Execute("select tmp.tps_prepa, tmp.tps_ctrl, tmp.tps_real, upper(rd.description) as description from (select w.id_labor_resource, nvl(w.id_downtime_code,0) as id_downtime_code, sum(nvl(w.setup_time_hc,0)) as tps_prepa, " _
                  & " sum(nvl(w.ctrl_time_hc,0))  as tps_ctrl, sum(nvl(w.work_time_hc, 0)) As tps_real from topmes.wip w where nvl(w.id_downtime_code, 0) <> 0 and nvl(w.id_labor_resource,0) = " & id_res & "" _
                  & " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by w.id_labor_resource, id_downtime_code) tmp inner join toppdm.resource_downtime_code rd " _
                  & " on tmp.id_downtime_code = rd.id_downtime_code")
                  
                  If Not rsRecord_badg.EOF Then
                     tps_real = rsRecord_badg.Fields("tps_prepa").Value + rsRecord_badg.Fields("tps_real").Value + rsRecord_badg.Fields("tps_ctrl").Value
                     ressource = rsRecord_badg.Fields("description")
                     If tps_real <> 0 Then
                        trouve = False
                        i = 3
                        Do Until trouve Or i > nb_lig_recap
                           If Worksheets("RECAP_SEM").Range("B" & i).Value = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i).Value = ressource And Worksheets("RECAP_SEM").Range("D" & i).Value = type_tps(3) Then
                              trouve = True
                           End If
                           i = i + 1
                        Loop
                        
                        If trouve Then
                           i = i - 1
                        Else
                           nb_lig_recap = nb_lig_recap + 1
                           With Worksheets("RECAP_SEM")
                              .Range("A" & i) = dpt_lu
                              .Range("B" & i) = nom_prenom
                              .Range("C" & i) = ressource
                              .Range("C" & i).Font.ColorIndex = 2
                              .Range("D" & i) = type_tps(3)
                           End With
                        End If
                       
                        Worksheets("RECAP_SEM").Activate
                        
                        Cells(i, colrecap).Value = tps_real
                     End If
                  End If                 
                  
                  rsRecord_badg2.Open "select upper(rp.description) as name, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.work_time_hc,0)) as tps_real, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl " _
                  & " from topmes.wip  w inner join toppdm.resource_downtime_code rp on nvl(w.id_downtime_code,0) = rp.id_downtime_code where nvl(w.id_labor_resource,0) = " & id_res & "  and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by rp.description", conn, adOpenForwardOnly, adLockReadOnly
                  If conn.State = adStateOpen Then
                     If Not rsRecord_badg2.EOF Then
                        rsRecord_badg2.MoveFirst
                        While Not rsRecord_badg2.EOF
                     
                          tps_prepa = rsRecord_badg2("tps_prepa").Value
                          tps_real = rsRecord_badg2("tps_real").Value
                          tps_ctrl = rsRecord_badg2("tps_ctrl").Value
                          poste = rsRecord_badg2("name").Value
                          tps_total = tps_prepa + tps_real + tps_ctrl
                          ' Si le temps total est différent de 0
                          If tps_total <> 0 Then
                            trouve = False
                            i = 3
                            Do Until trouve Or i > nb_lig_non_aff
                               If Worksheets("RECAP_NON_AFF").Range("B" & i) = nom_prenom And Worksheets("RECAP_NON_AFF").Range("C" & i) = poste Then
                                  trouve = True
                               End If
                               i = i + 1
                            Loop
                            
                             If trouve Then
                               i = i - 1
                            Else
                               nb_lig_non_aff = nb_lig_non_aff + 1
                               With Worksheets("RECAP_NON_AFF")
                                  .Range("A" & i) = dpt_lu
                                  .Range("B" & i) = nom_prenom
                                  .Range("C" & i) = poste
                               End With
                            End If
                        
                            Worksheets("RECAP_NON_AFF").Activate
                        
                            Cells(i, colnonaff).Value = tps_total
                          End If
                          rsRecord_badg2.MoveNext
                        Wend
                     End If
                  End If
                  rsRecord_badg2.Close
                  Set rsRecord_badg2 = Nothing                  
                              
                  rsRecord_badg2.Open "select upper(rp.description) as name, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.work_time_hc,0)) as tps_real, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl " _
                  & " from topmes.wip  w inner join toppdm.resource_downtime_code rp on nvl(w.id_downtime_code,0) = rp.id_downtime_code where nvl(w.id_labor_resource,0) = " & id_res & "  and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by rp.description", conn, adOpenForwardOnly, adLockReadOnly
                  If conn.State = adStateOpen Then
                     If Not rsRecord_badg2.EOF Then
                        rsRecord_badg2.MoveFirst
                        While Not rsRecord_badg2.EOF
                     
                          tps_prepa = rsRecord_badg2("tps_prepa").Value
                          tps_real = rsRecord_badg2("tps_real").Value
                          tps_ctrl = rsRecord_badg2("tps_ctrl").Value
                          poste = rsRecord_badg2("name").Value
                          tps_total = tps_prepa + tps_real + tps_ctrl
                          ' Si le temps total est différent de 0
                          If tps_total <> 0 Then
                            trouve = False
                            i = 3
                            Do Until trouve Or i > nb_lig_non_aff
                               If Worksheets("RECAP_NON_AFF").Range("B" & i) = nom_prenom And Worksheets("RECAP_NON_AFF").Range("C" & i) = poste Then
                                  trouve = True
                               End If
                               i = i + 1
                            Loop
                            
                            If trouve Then
                               i = i - 1
                            Else
                               nb_lig_non_aff = nb_lig_non_aff + 1
                               With Worksheets("RECAP_NON_AFF")
                                  .Range("A" & i) = dpt_lu
                                  .Range("B" & i) = nom_prenom
                                  .Range("C" & i) = poste
                               End With
                            End If
                        
                            Worksheets("RECAP_NON_AFF").Activate
                        
                            Cells(i, colnonaff).Value = tps_total
                          End If
                          rsRecord_badg2.MoveNext
                        Wend
                     End If
                  End If
                  rsRecord_badg2.Close
                  Set rsRecord_badg2 = Nothing
                                  
                              If dpt_lu <> dpt_traite Then
                     Set rsRecord_badg = conn.Execute("select d.name, sum(nvl(qty_completed,0)) as qte_travaillee from topmes.wip  w inner join topmes.resources r on w.id_labor_resource = r.id_resource inner join toppdm.resource_tree_item rt " _
                     & "on  r.id_resource = rt.id_resource inner join topsys.department d on rt.id_parent_origin = d.id_department where d.name = '" & dpt_lu & "' and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' and nvl(w.setup_time_hc,0) = 0 " _
                     & " and nvl(w.work_time_hc,0) = 0 and nvl(w.ctrl_time_hc,0) = 0 group by d.name")
                       If Not rsRecord_badg.EOF Then
                        qte_travaillee = rsRecord_badg.Fields("qte_travaillee").Value
                        If qte_travaillee <> 0 Then
                            With Worksheets("RECAP_SANS_TEMPS")
                                Set rfound = .Range("A4:A" & nb_lig_recap_stps).Find(dpt_lu, LookIn:=xlValues, lookat:=xlWhole)
                               If Not rfound Is Nothing Then
                                   lalig = rfound.Row
                                   Set rfound = Nothing
                                Else
                                   nb_lig_recap_stps = nb_lig_recap_stps + 1
                                   lalig = nb_lig_recap_stps
                                End If
                            End With
                            
                            Worksheets("RECAP_SANS_TEMPS").Activate
                            Cells(lalig, 1) = dpt_lu
                            Cells(lalig, colrecstps).Value = qte_travaillee
                        End If
                     End If
                  
                     dpt_traite = dpt_lu
                     
                  End If
                  
               End If
                              
               rsRecords.MoveNext
         Wend
         
         rsRecords.Close
         Set rsRecords = Nothing
   End If   
   
   nb_lig_stps = Worksheets("QTE_SANS_TEMPS").Cells(Application.Rows.Count, 1).End(xlUp).Row
   
   rsRecords.Open "select  case " _
       & " when r.id_resource in (4185, 4184, 2428, 2429,2430,2464) then 'DPT_DEBIT' " _
       & " when r.id_resource in (3901,2602,2764,4641) then 'DPT_CTRL_EXPEDITION' " _
       & " when r.id_resource in (3621,3821,4121,4281,4961,3321,3322,3581,2426,2460,2461,2462,3801,5021,2468,4781,5341) then 'DPT_FINITION' " _
       & " when r.id_resource in (3881,2463,2469) then 'DPT_QUALITE' " _
       & " when r.id_resource in (3181,2901,2902,3861,4161,4162,2621,2622,2623,3121,2424,2438,2458,2459,2466,2425,2467,2761,2763,5321) then 'DPT_SOUDURE' " _
       & " when r.id_resource in (5041,3241,3981,3982,4202,4241,2431,2432,2433,2434,2435,2436,2437,2439,2441) then 'DPT_TOLERIE' " _
       & " when r.id_resource in (4201,4581,2440,2442,2444,2445,2446,2447,2448,2449,2450,2451,2452,2453,2454,2455,2456,2457,2465) then 'DPT_USINAGE' " _
       & " when r.id_resource in (3083,4221) then 'DPT_GRENAILLEUSE' end    as DEPARTEMENT, r.name as ressource, tmp.qte_travaillee from " _
       & " (select nvl(w.id_resource,0) as id_resource, sum(nvl(w.qty_completed, 0)) As qte_travaillee from topmes.wip  w where TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "'" _
       & " and nvl(w.work_time_hc,0) = 0 and nvl(w.ctrl_time_hc,0) = 0 and nvl(w.id_resource,0) <> 0 group by nvl(w.id_resource,0)) tmp inner join toppdm.resources r on r.id_resource = tmp.id_resource left outer join toppdm.resource_tree_item rt " _
       & " on  r.id_resource = rt.id_resource left outer join topsys.department d on rt.id_parent_origin = d.id_department ", conn, adOpenForwardOnly, adLockReadOnly

   If conn.State = adStateOpen And Not rsRecords.EOF Then
         rsRecords.MoveFirst
         While Not rsRecords.EOF
         
           ressource = rsRecords.Fields("ressource").Value
           
           With Worksheets("QTE_SANS_TEMPS")
                Set rfound = .Range("B4:B" & nb_lig_stps).Find(ressource, LookIn:=xlValues, lookat:=xlWhole)
                If Not rfound Is Nothing Then
                   lalig = rfound.Row
                   Set rfound = Nothing
                Else
                   nb_lig_stps = nb_lig_stps + 1
                   lalig = nb_lig_stps
                End If
                
                .Range("A" & lalig).Value = rsRecords.Fields("DEPARTEMENT").Value
                .Range("B" & lalig).Value = ressource
                
           End With
           
           Worksheets("QTE_SANS_TEMPS").Activate
           Cells(lalig, colstps).Value = rsRecords.Fields("qte_travaillee").Value + Cells(lalig, colstps).Value
         
           rsRecords.MoveNext
         Wend
         rsRecords.Close
         Set rsRecords = Nothing
   End If
   
   conn.Close
   Set conn = Nothing
    
   If nb_lig_stps > num_lig_dep Then
          Worksheets("QTE_SANS_TEMPS").Range("B3").Select
    
        colstps = colstps + 1
      
      For i = Cells(3, 1).CurrentRegion.Rows.Count To 3 Step -1
          If colstps - 1 - nbinfostps > dureecons Then
              
           Cells(i, colstps).FormulaR1C1Local = "=NB.VIDE(L" & i & "C" & nbinfostps + 1 & " :L" & i & "C(-1))"
                                             
                 If Cells(i, colstps).Value > nbinfostps - 1 Then
                   Cells(i, 1).EntireRow.Delete
               Else
                   Cells(i, colstps).Value = ""
               End If
          End If
       Next
       colstps = colstps - 1
       
           For j = nbinfostps + 1 To colstps
                For i = 4 To nb_lig_stps
            If Cells(i, j).Value = "" Then
               Cells(i, j).Value = 0
            End If
          Next
       Next
   End If
   
      With Sheets("QTE_SANS_TEMPS")
        .Range(.Cells(3, 1), .Cells(nb_lig_stps, colstps)).Sort Key1:=.Range("A3"), Order1:=xlAscending, key2:=.Range("B3"), Order2:=xlAscending, Header:=xlYes
    End With       
     With Worksheets("QTE_SANS_TEMPS")
           .Range("A1").Value = "Date d'extraction : " & date_jour
           '.Range(.Cells(4, nbinfostps + 1), .Cells(nb_lig_stps, colstps)).NumberFormat = "0.00"
            With .Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).Font
              .Name = "Arial"
              .Size = 10
              .Strikethrough = False
              .Superscript = False
              .Subscript = False
              .OutlineFont = False
              .Shadow = False
              .Underline = xlUnderlineStyleNone
              .ColorIndex = xlAutomatic
          End With
          .Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).Columns.AutoFit
          .Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).HorizontalAlignment = xlCenter
          .Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).VerticalAlignment = xlBottom
   End With
   
   Worksheets("RECAP_SANS_TEMPS").Cells.Clear
    
   Worksheets("RECAP_SANS_TEMPS").Cells.Font.Bold = False
    
   With Worksheets("QTE_SANS_TEMPS")
       .Range(.Cells(1, 1), .Cells(3, colstps)).Copy
   End With
    
   Worksheets("QTE_SANS_TEMPS").Paste Destination:=Worksheets("RECAP_SANS_TEMPS").Range("A1")
    
   Worksheets("RECAP_SANS_TEMPS").Activate
    
   Columns("B:B").Delete Shift:=xlToLeft
           
   nbcol = colstps - nbinfostps
   
   fin_trt = False
          
   Worksheets("QTE_SANS_TEMPS").Activate
    
   i = 4
   ligsec = 4
    
   dpt_lu = Cells(i, 1).Value
     If dpt_lu = "" Then
       fin_trt = True
   End If
    
  Do Until fin_trt
    
       Worksheets("QTE_SANS_TEMPS").Activate
       
      Erase tableau
       
      ReDim tableau(colstps - 1 - nbinfostps)
       
     dpt_traite = dpt_lu
       
     Do Until fin_trt Or dpt_lu <> dpt_traite
          
          k = 0
          For j = nbinfostps + 1 To colstps
             tableau(k) = tableau(k) + Cells(i, j).Value
             k = k + 1
          Next j
           
          i = i + 1
          dpt_lu = Cells(i, 1).Value
         If dpt_lu = "" Then
             fin_trt = True
          End If
          
       Loop
       
       Worksheets("RECAP_SANS_TEMPS").Activate
       
       Cells(ligsec, 1) = dpt_traite
       
       For j = 0 To UBound(tableau)
           Cells(ligsec, j + 2) = tableau(j)
       Next j
       
       ligsec = ligsec + 1
       
   Loop
    
   Worksheets("RECAP_SANS_TEMPS").Activate    
   
   If ligsec > 4 Then
       Cells(ligsec, 1).Value = lib
       Cells(ligsec, 1).Font.Bold = True
       
       For j = 2 To colstps - 1
          Cells(ligsec, j).FormulaR1C1Local = "=SOMME(L4C" & j & ":L" & ligsec - 1 & "C" & j & ")"
       Next
       
   End If               
   
   nb_lig_recap_stps = Worksheets("RECAP_SANS_TEMPS").Range("A65536").End(xlUp).Row
   With Worksheets("RECAP_SANS_TEMPS")
           .Range("A1").Value = "Date d'extraction : " & date_jour     ' Police 10 aerial
          With .Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).Font
              .Name = "Arial"
              .Size = 10
              .Strikethrough = False
              .Superscript = False
              .Subscript = False
              .OutlineFont = False
              .Shadow = False
              .Underline = xlUnderlineStyleNone
              .ColorIndex = xlAutomatic
          End With
          .Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).Columns.AutoFit
          .Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).HorizontalAlignment = xlCenter
          .Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).VerticalAlignment = xlBottom
   End With   
   
   Worksheets("RECAP_SEM").Activate
   Worksheets("RECAP_SEM").Range("A3").Select
   dercol = 1
   While IsEmpty(ActiveCell) = False
       dercol = dercol + 1
       ActiveCell.Offset(0, 1).Activate
   Wend 
Worksheets("RECAP_SEM").Cells(Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row, colrecap)).ClearContents
                 
   nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row  
   
   Worksheets("RECAP_SEM").Activate
      
   coldeb = nbinforecap + 1
   
   nb_col = dercol - coldeb
   
   If nb_col > 4 Then   
               i = 4
        
        fin_trt = False
        
        If Cells(i, 1).Value = "" Then
           fin_trt = True
        End If
        
        Do Until fin_trt
           
           Cells(i, dercol).FormulaR1C1Local = "=NB.VIDE(L" & i & "C" & dercol - 6 & " :L" & i & "C" & dercol - 1 & ")"
           
            If Cells(i, dercol).Value > 4 Then
              Cells(i, 1).EntireRow.Delete
           Else
              i = i + 1
           End If
           
           If Cells(i, 1).Value = "" Then
              fin_trt = True
           End If
           
        Loop
        Columns(dercol).Delete
        
        nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
   End If
   
   nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
   
     If nb_lig_recap > 3 Then
        Worksheets("RECAP_SEM").Range("A:A").Insert Shift:=xlToRight
       Worksheets("RECAP_SEM").Range("A3").Value = "Tri"
             Worksheets("RECAP_SEM").Range("A4:A" & nb_lig_recap).FormulaR1C1 = "=RC[4]&RC[3]&RC[2]&RC[1]"
          Worksheets("RECAP_SEM").Range("A3:A" & nb_lig_recap).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlYes
       Columns("A").Delete Shift:=xlToLeft
   End If
   
   With Worksheets("RECAP_SEM")
           .Range("A1").Value = "Date d'extraction : " & date_jour
           .Range(.Cells(4, 5), .Cells(nb_lig_recap, dercol)).NumberFormat = "0.00"
          With .Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).Font
              .Name = "Arial"
              .Size = 10
              .Strikethrough = False
              .Superscript = False
              .Subscript = False
              .OutlineFont = False
              .Shadow = False
              .Underline = xlUnderlineStyleNone
              .ColorIndex = xlAutomatic
          End With
          .Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).Columns.AutoFit
          .Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).HorizontalAlignment = xlCenter
          .Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).VerticalAlignment = xlBottom
   End With   
    If nb_lig_non_aff > num_lig_dep Then
   
        Worksheets("TRI_NON_AFF").Cells.Clear        
        
        Worksheets("RECAP_NON_AFF").Range(Worksheets("RECAP_NON_AFF").Cells(4, 1), Worksheets("RECAP_NON_AFF").Cells(Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row, colrecap)).Copy
        
        Worksheets("TRI_NON_AFF").Paste Destination:=Worksheets("TRI_NON_AFF").Range("A1")
        
        Worksheets("RECAP_NON_AFF").Activate
        
        Worksheets("RECAP_NON_AFF").Range("A3").Select        
        
         dercol = 1
         While IsEmpty(ActiveCell) = False
            dercol = dercol + 1
            ActiveCell.Offset(0, 1).Activate
         Wend         
         
         dercol = dercol + 1         
         Worksheets("TRI_NON_AFF").Activate         
         Worksheets("TRI_NON_AFF").Range("A1").Select

         For i = Cells(1, 1).CurrentRegion.Rows.Count To 1 Step -1
             If dercol - 1 - nbinfononaff > dureecons Then
                   
                  Cells(i, dercol).FormulaR1C1Local = "=NB.VIDE(L" & i & "C" & nbinfononaff + 1 & " :L" & i & "C(-1))"                    
                    
                    If CInt(Cells(i, dercol).Value) >= dureecons And Left(Cells(i, 1).Value, 4) <> "zzzz" Then
                        Cells(i, 1).Value = "zzzz " & Cells(i, 1).Value
                       Worksheets("TRI_NON_AFF").Range(Cells(i, 1), Cells(i, dercol)).Font.ColorIndex = 10
                        Cells(i, dercol).Value = ""
                    End If
                    
                     If Cells(i, dercol).Value > nbinfononaff - 1 Then
                        Cells(i, 1).EntireRow.Delete
                    End If
             End If
         Next
         
         ' Tri de la feuille de tri des activités non affectées par opérateur et par poste
         With Sheets("TRI_NON_AFF")
             .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol)).Sort Key1:=.Range("A1"), Order1:=xlAscending, key2:=.Range("B1"), Order2:=xlAscending, Key3:=.Range("C1"), Order3:=xlAscending, Header:=xlNo
         End With
          
         ' Effacement du tableau contenu dans la feuille de RECAP_NON_AFF
         Worksheets("RECAP_NON_AFF").Range(Worksheets("RECAP_NON_AFF").Cells(4, 1), Worksheets("RECAP_NON_AFF").Cells(Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row, colrecap)).ClearContents
                   
         ' Copie de la feuille TRIRECAP dans la feuille RECAP_SEM
         With Worksheets("TRI_NON_AFF")
                      .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol - 1)).Copy
         End With
        
        Worksheets("RECAP_NON_AFF").Paste Destination:=Worksheets("RECAP_NON_AFF").Range("A4")
        
        nb_lig_non_aff = Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row
        
        dercol = dercol - 1
        ' Ajout de la semaine dans la dernière colonne de la ligne des entêtes
        Worksheets("RECAP_NON_AFF").Activate
        Cells(3, dercol).Value = annee_sem
        
        ' Mise en forme de la feuille RECAP_NON_AFF
        With Worksheets("RECAP_NON_AFF")
                .Range("A1").Value = "Date d'extraction : " & date_jour
                .Range(.Cells(4, 5), .Cells(nb_lig_non_aff, dercol)).NumberFormat = "0.00"
          ' Police 10 aerial
               With .Range(.Cells(1, 1), .Cells(nb_lig_non_aff, dercol)).Font
                   .Name = "Arial"
                   .Size = 10
                   .Strikethrough = False
                   .Superscript = False
                   .Subscript = False
                   .OutlineFont = False
                   .Shadow = False
                   .Underline = xlUnderlineStyleNone
                   .ColorIndex = xlAutomatic
               End With
               .Range(.Cells(1, 1), .Cells(nb_lig_non_aff, col)).Columns.AutoFit
               .Range(.Cells(1, 1), .Cells(nb_lig_non_aff, col)).HorizontalAlignment = xlCenter
               .Range(.Cells(1, 1), .Cells(nb_lig_non_aff, col)).VerticalAlignment = xlBottom
        End With
        ' fin si j'ai des données dans la feuille RECAP_NON_AFF
   End If
   
   ' Je vide la feuille de tri
   Worksheets("TRI").Cells.Clear
   
   ' Je copie le tableau dans la feuille de tri
  
  Worksheets("INDIV").Range(Worksheets("INDIV").Cells(4, 1), Worksheets("INDIV").Cells(Worksheets("INDIV").Range("A65536").End(xlUp).Row, col)).Copy
   
  Worksheets("TRI").Paste Destination:=Worksheets("TRI").Range("A1")
    
  Worksheets("TRI").Activate
    
  Worksheets("TRI").Range("A1").Select
    
  dercol = 1
  While IsEmpty(ActiveCell) = False
      dercol = dercol + 1
      ActiveCell.Offset(0, 1).Activate
  Wend    
    ' Si le nombre de colonnes avec valeurs est inférieur à la durée de l'historisation    
   If dercol - 1 - nbinfo > dureecons Then                                        
           ' On supprime la ligne si le nombre de lignes vides est > 50
           If Cells(i, dercol).Value > nbinfo - 1 Then
                Cells(i, 1).EntireRow.Delete
           End If
        End If
    
    ' Tri de la feuille de tri par département puis nom et prénom
    With Sheets("TRI")
        .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol)).Sort Key1:=.Range("A1"), Order1:=xlAscending, key2:=.Range("B1"), Order2:=xlAscending, Header:=xlNo
    End With
     
    ' Effacement du tableau contenu dans la feuille de INDIV
    Worksheets("INDIV").Range(Worksheets("INDIV").Cells(4, 1), Worksheets("INDIV").Cells(Worksheets("INDIV").Range("A65536").End(xlUp).Row, col)).ClearContents
              
    ' Copie de la feuille TRI dans la feuille INDIV
    With Worksheets("TRI")
             .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol - 1)).Copy
    End With
   
    Worksheets("INDIV").Paste Destination:=Worksheets("INDIV").Range("A4")
         
   ' Initialisation de la feuille de SECTEUR
    Worksheets("SECTEUR").Cells.Clear
    
    Worksheets("SECTEUR").Cells.Font.Bold = False
    
    ' Copie des entêtes de la feuille INDIV
    With Worksheets("INDIV")
       .Range(.Cells(1, 1), .Cells(3, dercol - 1)).Copy
    End With    
    Worksheets("INDIV").Paste Destination:=Worksheets("SECTEUR").Range("A1")
    Worksheets("SECTEUR").Activate
     ' Supression de la colonne opérateur
    Columns("B:B").Delete Shift:=xlToLeft
    
    ' Balayage des lignes de la feuille "SECTEUR" et totalisation par département différent de 'zzzz '
        
    ' Détermination du nombre de colonnes avec des données dans le tableau "SECTEUR" ( Département + données)
    nbcol = dercol - 1 - nbinfo
    
    fin_trt = False
          
    Worksheets("INDIV").Activate
    
    ' Positionnement sur la 4ème ligne
    i = 4
    ligsec = 4
    
    dpt_lu = Cells(i, 1).Value
    ' Si le département lu n'est pas renseigné ou qu'il commence par 'zz' alors on est en fin de traitement
    If dpt_lu = "" Or Left(dpt_lu, 5) = "zzzz " Then
       fin_trt = True
    End If
    
    ' on balaye tout le tableau jusqu'à obtenir le premier département avec 'zz' ou le département contient une cellule vide
    Do Until fin_trt
    
       Worksheets("INDIV").Activate
       
       ' Réinitialisation du tableau
       Erase tableau
       
       ' Le tableau contient le nom du département + la totalisation
       ReDim tableau(dercol - 2 - nbinfo)
       
       ' Alimentation du département dans le tableau           
       dpt_traite = dpt_lu
       
       ' on traite le département jusqu'à rupture ou fin de tableau
       Do Until fin_trt Or dpt_lu <> dpt_traite
          
          k = 0
          ' Alimentation du tableau
          ' On part du nombre d'information
          For j = nbinfo + 1 To dercol - 1
             tableau(k) = tableau(k) + Cells(i, j).Value
             k = k + 1
          Next j
           
          i = i + 1
          dpt_lu = Cells(i, 1).Value
          ' Si le département lu n'est pas renseigné ou qu'il commence par 'zz' alors on est en fin de traitement
          If dpt_lu = "" Or Left(dpt_lu, 5) = "zzzz " Then
             fin_trt = True
          End If
          
       Loop
       
       Worksheets("SECTEUR").Activate
       
       ' Bascule du tableau dans le classeur du secteur
       Cells(ligsec, 1) = dpt_traite
       
       For j = 0 To UBound(tableau)
           Cells(ligsec, j + 2) = tableau(j)
       Next j
       
       ' Ajout d'une ligne sur le tableau indiv
       ligsec = ligsec + 1
       
    Loop
    
    Worksheets("SECTEUR").Activate
    
    ' Ajout du total général
    If ligsec > 4 Then
       Cells(ligsec, 1).Value = "Total général"
       Cells(ligsec, 1).Font.Bold = True
       
       For j = 2 To dercol - nbinfo
          Cells(ligsec, j).FormulaR1C1Local = "=SOMME(L4C" & j & ":L" & ligsec - 1 & "C" & j & ")"
       Next
    End If
    
    ' Mise en forme de la feuille SECTEUR
    With Worksheets("SECTEUR")
           .Range("A1").Value = "Date d'extraction : " & date_jour
           .Range(.Cells(3, 1), .Cells(ligsec, col)).NumberFormat = "0.00"
     ' Police 10 aerial
          With .Range(.Cells(1, 1), .Cells(ligsec, col)).Font
              .Name = "Arial"
              .Size = 10
              .Strikethrough = False
              .Superscript = False
              .Subscript = False
              .OutlineFont = False
              .Shadow = False
              .Underline = xlUnderlineStyleNone
              .ColorIndex = xlAutomatic
          End With
          .Range(.Cells(1, 1), .Cells(ligsec, col)).Columns.AutoFit
    End With
    
    ' Ajout des indicateurs en bas de la feuille INDIV
    
    Worksheets("INDIV").Activate
    
    ' Récupération du nombre total de lignes dans la feuille INDIV
    nb_lig = Worksheets("INDIV").Range("A65536").End(xlUp).Row
    
    lig = nb_lig + 1
    
    ' Mise en place en colonne des indicateurs par semaine :
    ' - moyennes,
    ' - écart-type,
    ' - écart-type rapporté à la moyenne.
    '
    ' Wiki : La notion d'écart type élevé n'a aucun sens dans l'absolu.
    ' Elle ne traduit une forte dispersion que si on rend la valeur adimensionnelle en la divisant par la moyenne
    
    Worksheets("INDIV").Range("A3").Select
    
    ' Détermination de la première colonne vide
    col = 1
    While IsEmpty(ActiveCell) = False
      col = col + 1
      ActiveCell.Offset(0, 1).Activate
    Wend
    
    col = col - 1
    
    Cells(lig, 1).Value = indicateur(0)
    Cells(lig, 1).Font.Bold = True
    Cells(lig + 1, 1).Value = indicateur(1)
    Cells(lig + 1, 1).Font.Bold = True
    Cells(lig + 2, 1).Value = indicateur(2)
    Cells(lig + 2, 1).Font.Bold = True
    Cells(lig + 3, 1).Value = indicateur(3)
    Cells(lig + 3, 1).Font.Bold = True
    Cells(lig + 4, 1).Value = indicateur(4)
    Cells(lig + 4, 1).Font.Bold = True
    
    For i = 3 To col Step 1
        ' Moyenne
        Cells(lig, i).FormulaR1C1Local = "=MOYENNE(L4C" & i & ":L" & nb_lig & "C" & i & ")"
        ' Ecart-type
        Cells(lig + 1, i).FormulaR1C1Local = "=ECARTYPEP(L4C" & i & ":L" & nb_lig & "C" & i & ")"
        ' Ecart-type rapporté à la moyenne
        Cells(lig + 2, i).Value = Cells(lig + 1, i).Value / Cells(lig, i).Value
        ' Nombre de personnes présentes n'ayant pas badgées (cellules contenant 0)
        Cells(lig + 3, i).FormulaR1C1Local = "=NB.SI(L4C" & i & ":L" & nb_lig & "C" & i & ";0)"
        
        ' Nombre de cellules différentes de 0
        Cells(lig + 5, i).FormulaR1C1Local = "=NB.SI(L4C" & i & ":L" & nb_lig & "C" & i & ";""<>0"")"
        
        ' Nombres de personnes ayant badgées (cellules différentes de 0 - nb de cellules vides)
        ' Cells(lig + 5, i).FormulaR1C1Local = "=NB.SI(L4C" & i & ":L" & nb_lig & "C" & i & ";'<>0')"
        ' Nombre de personnes absentes
        Cells(lig + 6, i).FormulaR1C1Local = "=NB.VIDE(L4C" & i & ":L" & nb_lig & "C" & i & ")"
        
        ' Renseignement du nombre de personnes ayant badgées
        Cells(lig + 4, i).Value = Cells(lig + 5, i).Value - Cells(lig + 6, i).Value
        Cells(lig + 5, i).Value = ""
        Cells(lig + 6, i).Value = ""
    Next i
        
    ' Permet de désactiver le presse papier
    Application.CutCopyMode = False
               
    With Worksheets("INDIV")
           With .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).Font
              .Name = "Arial"
              .Size = 10
              .Strikethrough = False
              .Superscript = False
              .Subscript = False
              .OutlineFont = False
              .Shadow = False
              .Underline = xlUnderlineStyleNone
              .ColorIndex = xlAutomatic
          End With
          .Range("A1").Value = "Date d'extraction : " & date_jour
          .Range(.Cells(3, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).NumberFormat = "0.00"
          ' Les 2 dernières lignes de la feuille INDIV soivent être au format 0
          .Range(.Cells(.Range("A65536").End(xlUp).Row - 1, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).NumberFormat = "0"
          .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).Columns.AutoFit
     End With    
      ' Définition de la zone d'impression
      
   MsgBox "Traitement terminé !"
   
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   
   Worksheets("SECTEUR").Activate
   Worksheets("SECTEUR").Range("A1").Select
   
   UserForm1.Hide
   
End Sub

' ---
' CALCUL DU 1ER JOUR D'UNE SEMAINE DONNEE
' ---
' La semaine est calculée "à la française".
' Remplacer vbMonday et vbFirstFourDays pour d'autres
' méthodes.
'
Function DateSemaineFR( _
  ByVal intAnnee As Integer, _
  Optional ByVal intSemaine As Integer = 1)
  
  Dim dt As Date
  
  ' Trouver le 1er jour de la semaine 1 de l'année
  ' (pas forcément le 1/1/aaaa en France !)
  dt = DateSerial(intAnnee, 1, 1)
  While DatePart("ww", dt, vbMonday, vbFirstFourDays) <> 1
    dt = dt + 1
  Wend
  
  ' Calculer le 1er jour de la semaine demandée
  dt = dt - DatePart("w", dt, vbMonday) + 1
  dt = dt + 7 * (intSemaine - 1)
  
  DateSemaineFR = dt
End Function


' ---
' CALCUL DU NO DE SEMAINE A PARTIR D'UNE DATE
' ---
Function nsem(ByVal wdate As Date)

  ' Variable utilisée pour récupérer le numéro de semaine
   Dim Jan03 As Long
   
   ' N° de semaine (norme iso)
   Dim nosem As Integer
     
   ' Récupération du numéro de semaine en cours
   
   Jan03 = DateSerial(Year(wdate - Weekday(wdate - 1) + 4), 1, 3)
   nosem = Int((wdate - Jan03 + Weekday(Jan03) + 5) / 7)
   nsem = nosem
    
End Function

Private Sub UserForm_Activate()

   Dim conn As New ADODB.Connection
   Dim connString
   Dim rsRecords As New ADODB.Recordset

   ' Récupération de la date du jour
   Dim datejour, date_debut As Date
   
   ' Date du premier jour de la semaine
   Dim datepremjour As Date
   
   ' Variable utilisée pour récupérer le numéro de semaine
   Dim Jan03 As Long
   
   ' N° de semaine (norme iso)
   Dim nosem, num_annee As Integer
   
   connString = "DSN=TOP;Uid=TOPMAN01;Pwd=TOPMAN01"
   conn.Open connString
   
   ' Récupération du numéro de semaine du jour
   
   nosem = nsem(Date)
   
   num_annee = Format(Now, "yyyy")
   
   ' Si la semaine actuelle est '01' alors la semaine précédente est la dernière de l'année précédente
   If nosem = 1 Then
      num_annee = num_annee - 1
      nosem = 52
   Else
      nosem = nosem - 1
   End If
      
   ' Récupération du premier jour de la semaine précédent la date du jour
   datepremjour = DateSemaineFR(num_annee, nosem)
   
   ' Récupération de la semaine
   
   ' On regarde si le premier jour de la semaine précédente était dans des congés.
   ' Si tel était le cas, on prend la semaine précédent les congés
   ' Sinon on prend la semaine précédente
   
   ' On recherche si la semaine précédente correspondait à des congés
   Set rsRecords = conn.Execute("select rb.date_start as date_debut from resource_calendar rc inner join resource_calendar_band rb on rb.id_resource_calendar = rc.id_resource_calendar where rc.reference = 'METAL 44' and nvl(rb.type,0) = 6  and rb.date_start <= '" & datepremjour - 7 & "' and rb.date_end >= '" & datepremjour & "'")
   If Not rsRecords.EOF Then
   ' La semaine précédente correspondait à des congés, on récupére la 1ère semaine où nous n'étions pas en congés
       date_debut = CDate(rsRecords.Fields("date_debut").Value) - 1
       nosem = nsem(date_debut)
       num_annee = Format(date_debut, "yyyy")
   End If
   
   rsRecords.Close
   Set rsRecords = Nothing
   
   sem.Value = nosem
   ann.Value = num_annee
   
   sem.SetFocus
   
End Sub
 

Si...

XLDnaute Barbatruc
Re : Plantage sur l'instruction Application.ScreenUpdating = True

salut

ce n'est pas le genre d'instruction qui peut poser problème; peut-être une raison ici (puis ici).

Remarque : une macro hors contexte et surtout longue comme un jour sans pain est aussi souvent indigeste.
 

Modeste geedee

XLDnaute Barbatruc
Re : Plantage sur l'instruction Application.ScreenUpdating = True

Bonsour®
:confused: :mad:
- dans code long comme un jour sans fin, aucune gestion d'erreur...
- un code en dehors de tout découpage fonctionnel ou modulaire

d'abord faire un test en modifiant les options du projet :
Capture.JPG
à fin de traquer les erreurs conceptuelles.
régler chaque cas rencontré...:p
ensuite
remodifier les options du projet :
Capture2.JPG
afin de traquer les erreurs non dues au code (Windows, réseau etc..)
refaire un test.

bon courage si tu n'es pas l'auteur du code...
les commentaires d'instructions ne sont pas de l'aide suffisante au débuggage :(
par contre l'organigramme de la macro serait d'une grande aide :rolleyes:
 

Pièces jointes

  • Capture.JPG
    Capture.JPG
    42.7 KB · Affichages: 46
  • Capture.JPG
    Capture.JPG
    42.7 KB · Affichages: 51
  • Capture2.JPG
    Capture2.JPG
    42.7 KB · Affichages: 48
  • Capture2.JPG
    Capture2.JPG
    42.7 KB · Affichages: 53

ROGER2327

XLDnaute Barbatruc
Re : Plantage sur l'instruction Application.ScreenUpdating = True

Bonjour à tous.


C'est touffu !

Je ne vois pas la solution au problème évoqué. Par contre, plantage assuré sur cette ligne :​
Code:
Worksheets("RECAP_SEM").Cells(Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row, colrecap)).ClearContents
(Plus de fermetures de parenthèses que d'ouvertures.)


Bon courage.


ℝOGER2327
#7586


Jeudi 26 Absolu 142 (Saint Joseb, notaire à la mode de Bretagne - fête Suprême Quarte)
12 Vendémiaire An CCXXIII, 6,1670h - immortelle
2014-W40-5T14:48:03Z
 

job75

XLDnaute Barbatruc
Re : Plantage sur l'instruction Application.ScreenUpdating = True

Bonsoir à tous,

Bravo pour le code du post #3 - 1421 lignes * - record battu.

Les adeptes du "plus c'est long plus c'est bon" prolifèrent sur XLD :rolleyes:

* Edit : en retirant les lignes vides ou avec seulement des "espaces" il reste 1090 lignes, c'est encore très bien.

A+
 
Dernière édition:

camarchepas

XLDnaute Barbatruc
Re : Plantage sur l'instruction Application.ScreenUpdating = True

Bonjour Job, Roger, Modeste geedee, Si et Juju ,

Waouh , c'est vrai , ça donne surtout envie de refermer et d'aller voir ailleurs .
De l'écriture au kilométre, tous cela dans une procédure événementielle de formulaire, ça impressionne ,
mais surtout ça fonctionne pas , et la maintenance bonjour,
Car c'est sur, c'est pas cette instruction qui est en cause .

Désolé , mais il faut de le dire Juju , c'est un basard désorganisé .

Comme principe de base pour mettre au pôint et maintenir confortablement du code c'est pas le top, car on sait tous qu'un programme utilisé réguliérement , à toujours besoin d"évolutions ou de sécurité liées à des événement éxtérieurs que l'on avait pas forcement en tête au moment de l'écriture .

Donc , là imagine reviens 3 mois aprés , t-y comprends plus rien , même des commentaires ne suffiraient pas là .

La premiére chose à faire , découpe ton code et tous ce qui n'est pas scritement lié à l'userform mets le dans des routines ou fonctions dans un ou plusieurs modules standards .

J'ai vu de l'acquisition de données , cela pourrait être mis dans un module dédier , etc ,

une fois le découpage fait tu vas meme peut être t'apercevoir qu'il y a du code similaire ou strictement identique , des fois ça vaux le coup d'en faire une fonction.

Mais je ne pense pas que quelqu'un du forum le fera à ta place, surtout sans le classeur pour tester et valider les macro .

une solution pour les débutants et même les autres , est de n'écrire que des comentaires au début, ensuite de créer des boites pour les différentes fonctions nécessaires et enfin là tranquillement travailler sur du code à échelle humaine .

Ensuite , si ton problème persiste , tu pourras revenir vers nous , mais je suis certain que c'est autre chose qui ce cache la dessous.

bon courage et bon découpage , à bientot
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T