Bonjour, Re-Bonjour les amis !!

Mon code VBA s'achève aujourd'hui, merci à la communautée de developpez.net pour l'aide que vous m'avez apporté !

Voilà, sela fait maintenant 1 mois que je connais le language partiellement de VBA et, je pense, que je m'en sort pas trop mal

Mon code :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Sub Macro1()
 
Dim base As Worksheet
 Set base = Worksheets(1)
Dim Tabl As Worksheet
 Set Tabl = Worksheets(3)
Dim ws As Worksheet
Dim name As String
Dim val As Worksheet
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
Dim shCounter As Integer
shCounter = 28
Dim Shune As String
Shune = ThisWorkbook.Sheets(1).name
 
 
    Sheets(1).Select
    Columns("A:A").Delete Shift:=xlToLeft
    Rows("1:1").Delete Shift:=xlUp
     Sheets(2).Select
    Columns("A:A").Delete Shift:=xlToLeft
    Rows("1:1").Delete Shift:=xlUp
     Sheets(1).Select
    Range("K2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-9],Maladie!C[-10]:C[-3],3,FALSE))=TRUE,""En forme"",VLOOKUP(RC[-9],Maladie!C[-10]:C[-3],3,FALSE))"
    Sheets(1).Select
    Range("K2").AutoFill Destination:=Range("K2:K" & Range("B65536").End(xlUp).Row)
    Range("K2").Select
Dim O As Worksheet 'déclare la variable O (onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim C As Range 'déclare la variable C (Cellule)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Worksheets(1) 'définit l'onglet O (à adapter à ton cas)
DL = O.Cells(Application.Rows.Count, "J").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne J de l'onglet O
Set PL = O.Range("J1:J" & DL) 'définit la plage PL
For Each C In PL 'boucle sur toutes les cellules C de la plage PL
    'si la valeur de la cellule C em majuscule vaut "TEMPS PARTIEL DE DROIT AU PROFIT DES TRAVAILLEURS HANDICAPÉS", redéfinit la valeur avec "TP de droit"
    If UCase(C.Value) = "TEMPS PARTIEL DE DROIT AU PROFIT DES TRAVAILLEURS HANDICAPÉS" Then C.Value = "TP de droit"
    If UCase(C.Value) = "TEMPS PARTIEL DE DROIT POUR SOINS À CONJOINT OU ENFANT OU ASCENDANT" Then C.Value = "TP de droit"
    If UCase(C.Value) = "TEMPS PARTIEL POUR RAISON THÉRAPEUTIQUE APRÈS CMO OU CLM OU CLD" Then C.Value = "TP de droit"
    If UCase(C.Value) = "TEMPS PARTIEL DE DROIT À L'OCCASION D'UNE NAISSANCE OU D'UNE ADOPTION" Then C.Value = "TP de droit"
    If UCase(C.Value) = "TEMPS PARTIEL POUR RAISON THÉRAPEUTIQUE APRÈS ACCIDENT DE SERVICE OU MALADIE PROFESSIONNELLE" Then C.Value = "TP de droit"
        If UCase(C.Value) = "TEMPS PARTIEL DE DROIT À L'OCCASION D'UNE NAISSANCE OU D'UNE ADOPTION (SUR TNC)" Then C.Value = "TP de droit"
Next C 'prochaine cellule de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
 
For shCounter = 4 To 31
Sheets.Add After:=Worksheets(Worksheets.Count())
mainworkBook.Sheets(shCounter).name = mainworkBook.Sheets(3).Range("E" & shCounter).Value
 
    For wkCounter = 1 To 28
    pole = ThisWorkbook.Sheets(3).Range("G" & wkCounter).Value
 
    base.Activate
    Rows("1:1").AutoFilter
    i = Range("A65536").End(xlUp).Row
    ActiveSheet.Range("$A$1 : $A" & i).AutoFilter Field:=1, Criteria1:=Sheets(3).Range("E" & shCounter).Value
    i = Range("A65536").End(xlUp).Row
    Rows("1:" & i).Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    Range("A1").Select
    ActiveSheet.Paste
    Tabl.Activate
    Range("A1:C31").Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    Range("O1").Select
    ActiveSheet.Paste
        With ActiveCell 'Début de l'instruction avec : WITH
         .Borders.Value = 1
         With .Font
             .Size = 12
             .name = "Arial"
         End With
     End With
     Range("A1:L1").Font.ColorIndex = 46
     Columns("O:O").EntireColumn.AutoFit
 
    Sheets(shCounter).Select
    Range("O1:Q28").Select
    Selection.Copy
        Workbooks.Open Filename:= _
        "F:\Partages\Commun_DRH\Taux de recouvrement\Evolution\2018\" & pole & ".xls"
    Sheets(Shune).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWorkbook.Close
 
Next
Next
 
    name = ThisWorkbook.Sheets(1).name ' Nom du workbook
 
    ActiveWorkbook.SaveAs "F:\Partages\Commun_DRH\Taux de recouvrement\Année 2018\" & name & ".xls"
    Sheets(Array(3)).Select
    ActiveWindow.SelectedSheets.Delete
 
 
End Sub
Cependant, il me reste une seule petite erreur sur ma boucle que je ne saisie pas bien :

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
For shCounter = 4 To 31
Sheets.Add After:=Worksheets(Worksheets.Count())
mainworkBook.Sheets(shCounter).name = mainworkBook.Sheets(3).Range("E" & shCounter).Value
 
    For wkCounter = 1 To 28
    pole = ThisWorkbook.Sheets(3).Range("G" & wkCounter).Value
 
    base.Activate
    Rows("1:1").AutoFilter
    i = Range("A65536").End(xlUp).Row
    ActiveSheet.Range("$A$1 : $A" & i).AutoFilter Field:=1, Criteria1:=Sheets(3).Range("E" & shCounter).Value
    i = Range("A65536").End(xlUp).Row
    Rows("1:" & i).Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    Range("A1").Select
    ActiveSheet.Paste
    Tabl.Activate
    Range("A1:C31").Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    Range("O1").Select
    ActiveSheet.Paste
        With ActiveCell 'Début de l'instruction avec : WITH
         .Borders.Value = 1
         With .Font
             .Size = 12
             .name = "Arial"
         End With
     End With
     Range("A1:L1").Font.ColorIndex = 46
     Columns("O:O").EntireColumn.AutoFit
 
    Sheets(shCounter).Select  
    Range("O1:Q28").Select
    Selection.Copy
        Workbooks.Open Filename:= _
        "F:\Partages\Commun_DRH\Taux de recouvrement\Evolution\2018\" & pole & ".xls"
    Sheets(Shune).Select ''''''Select le nom de la feuille 1 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWorkbook.Close
 
Next
Next
Je ne comprend pas pourquoi sur cette boucle, la macro supprime toutes les feuilles excel et enregistre la même feuille sur tous les dossiers alors qu'elle devrait enregistrer chaque feuille
sur un seul et même dossier !!

Merci indéfiniement !