Archivage qui fonctionne mal

[Bricoltou]

Bondoir le Fil

J'ai écrit ce code afin d'archiver un fichier A, puis copie d'un autre fichier B que je copie sur le A .
La macro fonctione mal car je n'arrive pas a vider les cellules dans les onglets de la semaine (Ligne bleu du code )

Pouvez vous m'aider ?
Merci d'avance

Bricoltou

Private Sub ListBoxarchive_Change()
Select Case ListBoxarchive.Value
Case "Matrice_Chauffeur"
        Workbooks.Open Filename:= _
      "C:\Documents and Settings\Desktop\Camionnage\Matrice_Chauffeur.xls"
      Application.DisplayAlerts = True
      Dim no_sem As String
      ActiveSheet.Unprotect Password:="Terminal"
      no_sem = InputBox("Saisissez le numéro de la semaine ", "No de semaine")
     ChDir "C:\Documents and Settings\Desktop\Camionnage\Archives\Planning"
       ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\Desktop\Camionnage\Archives\Planning\" & "Planning" & no_sem & ".xls"
      Application.DisplayAlerts = False
      ActiveWorkbook.Close
         Workbooks.Open Filename:= _
           "C:\Documents and Settings\Desktop\Camionnage\Matrice_Chauffeur.xls"
            ActiveSheet.Unprotect Password:="Terminal"
            Range("B3").Select
            Selection.ClearContents
            Range("A" & 6 + decalage_cellule_vers_le_bas & ":H" & 23 + decalage_cellule_vers_le_bas).Select
            Selection.ClearContents
            Range("A" & 24 + decalage_cellule_vers_le_bas & ":H" & 42 + decalage_cellule_vers_le_bas).Select
            Selection.ClearContents
            Range("A" & 43 + decalage_cellule_vers_le_bas & ":H" & 58 + decalage_cellule_vers_le_bas).Select
            Selection.ClearContents
            Range("C4:H5").Select
            Selection.ClearContents
            ActiveSheet.Protect Password:="Terminal"
        ActiveWorkbook.Close
Workbooks.Open Filename:= _
"C:\Documents and Settings\Desktop\Camionnage\Matrice_Chauffeur.xls"
[COLOR="Blue"]Sheets("Lundi").Select
     ActiveSheet.Unprotect Password:="Terminal"
     Range("D3:M54").Select
     Selection.ClearContents
     Range("P3:T54").Select
     Selection.ClearContents
     ActiveSheet.Protect Password:="Terminal"
Sheets("Mardi").Select
     ActiveSheet.Unprotect Password:="Terminal"
     Range("D3:M54").Select
     Selection.ClearContents
     Range("P3:T54").Select
     Selection.ClearContents
     ActiveSheet.Protect Password:="Terminal"
Sheets("Mercredi").Select
     ActiveSheet.Unprotect Password:="Terminal"
     Range("D3:M54").Select
     Selection.ClearContents
     Range("P3:T54").Select
     Selection.ClearContents
     ActiveSheet.Protect Password:="Terminal"
Sheets("Jeudi").Select
     ActiveSheet.Unprotect Password:="Terminal"
     Range("D3:M54").Select
     Selection.ClearContents
     Range("P3:T54").Select
     Selection.ClearContents
     ActiveSheet.Protect Password:="Terminal"
Sheets("Vendredi").Select
     ActiveSheet.Unprotect Password:="Terminal"
     Range("D3:M54").Select
     Selection.ClearContents
     Range("P3:T54").Select
     Selection.ClearContents
     ActiveSheet.Protect Password:="Terminal"[/COLOR] 
Workbooks.Open Filename:= _
            "C:\Documents and Settings\Desktop\Camionnage\Matrice_Chauffeur2.xls"
             Application.DisplayAlerts = False
             Workbooks.Open Filename:= _
           "C:\Documents and Settings\Desktop\Camionnage\Matrice_Chauffeur.xls"
            ActiveWorkbook.Save
            Application.DisplayAlerts = True
            ActiveWorkbook.Close
            Workbooks.Open Filename:= _
           "C:\Documents and Settings\Desktop\Camionnage\Matrice_Chauffeur2.xls"
            Range("B3").Select
            Selection.ClearContents
            Range("C4:G5").Select
            ActiveSheet.Unprotect Password:="Terminal"
            Selection.ClearContents
            Range("A6:G35").Select
            Selection.ClearContents
     ActiveSheet.Protect Password:="Terminal"
     ActiveWorkbook.Save
     ActiveWorkbook.Close

 

[Paritec]

Re : Archivage qui fonctionne mal

Bonjour Bricoltou
déjà tu peux retirer tous les select et tu as combien de feuilles dans ton classeur que lundi à vendredi?
si tu fournis un petit fichier tu auras plus de chance
a+
papou

 

[JNP]

Re : Archivage qui fonctionne mal

Bonjour le fil ,
Essaie

Dim Feuille As Worksheet
For Each Feuille In ActiveWorkbook.Worksheets
Select Case Feuille.Name
Case "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi"
With Feuille
.Unprotect Password:="Terminal"
.Range("D3:M54").ClearContents
.Range("P3:T54").ClearContents
.Protect Password:="Terminal"
End With
End Select
Next

Bonne journée

 

[Bricoltou]

Re : Archivage qui fonctionne mal

Bonsoir le Fil , Paritec,JNP

Merci pour vos réponses vos codes fonctionne

Encore merci pour votre aide

Bricoltou