Bonsoir,

C'est un sujet récurant sur le forum pour l'avoir vu et consulter bien des fois ces derniers jours.
Je n'arrive pas à voir ma solution parmi les post concernant cela.

Donc ma problématique est la suivante:

Je n'ai qu'une colonne à filtrer (la I) copier les valeurs dans un autre classeur faire mes bidouilles sur ce nouveau classeur l'enregistrer en le nommant avec le nom de mon criteria1.

J'ai 27 criteria1 dans une liste et mon souci c'est qu'il reste sur la valeur I1, ne passe pas à la suivante.
Je ne crois pas m'être trompé (bien que ça ne fonctionne pas).

Merci beaucoup pour votre aide.

(NB je sais que les lignes 117 à 120 ne sont pas bonnes encore mais je vais chercher)



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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
 Dim Cell As Variant
 
    Dim derlig As Long
    derlig = Range("a" & Rows.Count).End(xlUp).Row
 
    For Each Cell In Sheets("ref").Range("I1:I30")
 
    Dim crit As String
    crit = ActiveCell.Value
 
    If crit = "" Then Exit For
 
    Sheets("travail").Select
    ActiveSheet.Range("$A$2:$J$" & derlig).AutoFilter Field:=9, Criteria1:=crit
    cells.Copy
 
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
 
'insertion de la formule de comptage
 
    Dim derligf As Long
    derligf = Range("a" & Rows.Count).End(xlUp).Row
 
    Range("i1").Select
    ActiveCell.FormulaR1C1 = "nombre"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R2C8:R100000C8,RC[-1])"
    Range("I2").Select
    Selection.AutoFill Destination:=Range("I2:I" & derligf)
    Range("I2:I" & derligf).Select
 
'déplacement de la colonne de comptage
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Nombre"
    Range("I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("L2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("M1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Maintien"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "Observation"
 
'suppression des doublons
    Columns("A:L").Select
    ActiveSheet.Range("$A$1:$L$" & derligf).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6 _
        , 7, 8, 9, 10, 11, 12), Header:=xlNo
 
    Columns("H:I").Select
    Selection.Delete Shift:=xlToLeft
 
'mise en forme du tableau
    Range("A1:L1").Select
    Selection.AutoFilter
    Range("A1:L1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
 
    Range("A1:L1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").ColumnWidth = 22.29
    Columns("D:D").ColumnWidth = 25.29
    Columns("H:H").ColumnWidth = 16.86
 
'Enregistrement sous le code de prestation 2 lettres
    ActiveWorkbook.SaveAs Filename:= _
        "chemin " & crit & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
 
    crit = Empty
    derligf = Empty
 
    Next Cell