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
| Sub CreationPage()
Dim Fe1 As Worksheet
Dim Fe2 As Worksheet
Dim Fe3 As Worksheet
Dim Cel As Range
Dim I As Integer
'ajoute le nombre de feuilles désirées
'fige l'écran
Application.ScreenUpdating = False
If [D2].Value = 4 Then
Worksheets("Gr.de 4").Copy , Sheets(Sheets.Count)
For I = 1 To Worksheets("Tirage Groupes").[C2]
Set Fe1 = ActiveSheet
With Fe1
.Name = "Gr." & Chr(64 + I) 'nomme la feuille
.Range("A1") = "Groupe " & Chr(64 + I) 'titre
'évite la 1ère feuille afin de laisser les lettres A
If I > 1 Then
'boucle sur les cellules contenant des valeurs constantes
For Each Cel In .Cells.SpecialCells(2)
'contrôle que la valeur après la lettre est une valeur numérique
'afin de ne pas modifier les mots comme "TOTAL"
If IsNumeric(Mid(Cel.Value, 2, 1)) Then
Cel.Value = Replace(Cel.Value, "A", Chr(64 + I), , , 0)
End If
Next Cel
End If
End With
Next I
'rafraîchi
Application.ScreenUpdating = True
Elself: [D2].Value = 5
Worksheets("Gr.de 5").Copy , Sheets(Sheets.Count)
For I = 1 To Worksheets("Tirage Groupes").[C2]
Set Fe2 = ActiveSheet
With Fe2
.Name = "Gr." & Chr(64 + I) 'nomme la feuille
.Range("A1") = "Groupe " & Chr(64 + I) 'titre
'évite la 1ère feuille afin de laisser les lettres A
If I > 1 Then
'boucle sur les cellules contenant des valeurs constantes
For Each Cel In .Cells.SpecialCells(2)
'contrôle que la valeur après la lettre est une valeur numérique
'afin de ne pas modifier les mots comme "TOTAL"
If IsNumeric(Mid(Cel.Value, 2, 1)) Then
Cel.Value = Replace(Cel.Value, "A", Chr(64 + I), , , 0)
End If
Next Cel
End If
End With
Next I
'rafraîchi
Application.ScreenUpdating = True
Else: [D2].Value = 9
Worksheets("Gr.de 9").Copy , Sheets(Sheets.Count)
End If
For I = 1 To Worksheets("Tirage Groupes").[C2]
Set Fe3 = ActiveSheet
With Fe3
.Name = "Gr." & Chr(64 + I) 'nomme la feuille
.Range("A1") = "Groupe " & Chr(64 + I) 'titre
'évite la 1ère feuille afin de laisser les lettres A
If I > 1 Then
'boucle sur les cellules contenant des valeurs constantes
For Each Cel In .Cells.SpecialCells(2)
'contrôle que la valeur après la lettre est une valeur numérique
'afin de ne pas modifier les mots comme "TOTAL"
If IsNumeric(Mid(Cel.Value, 2, 1)) Then
Cel.Value = Replace(Cel.Value, "A", Chr(64 + I), , , 0)
End If
Next Cel
End If
End With
Next I
'rafraîchi
Application.ScreenUpdating = True
End Sub |
Partager