Bonsoir tout le monde,

Mon souhait pour ce fichier était :

- La création d'une feuille pour chaque stage (manuelle)
- La Feuil1 qui récapitule tous les renseignements de tous les stages (VBA)
- La création d'une feuille par personne, puis pouvoir les supprimer à ma guise (VBA)

Le bouton 1 (Récap formation) et le 2 (Effacer le récap) sont OK. Les macros fonctionnent.
Le bouton 3 (Créer feuille par personne) ne fonctionne plus correctement, me rajoute une feuil2 seulement !!!
Le bouton 4 (Effacer les feuilles nominatives) supprime la feuil1 que je veux conserver(avec toutes les feuilles datées).

Merci à vous de m’aider à écrire ces codes correctement.
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
Sub Macro1()
'
' Macro1 Macro
'
 
Dim i As Integer
Dim Cel As Range
Dim lig As Integer 'ligne dans feuille recap
Dim ligne As Integer 'ligne dans feuille de recherche
 
lig = 4
 
 
For i = 2 To Sheets.Count
 
    ligne = 11
 
    For Each Cel In Sheets(i).Range("d12:d26")
        ligne = ligne + 1
 
        If IsDate(Cel.Value) Then
 
            lig = lig + 1 'ligne où copier dans recap
            'copie NOM
            Sheets("Feuil1").Range("A" & lig) = Sheets(i).Range("A" & ligne)
            'copie FORMATION
            Sheets("Feuil1").Range("B" & lig) = Sheets(i).Range("B" & ligne)
            'copie DATE DEBUT
            Sheets("Feuil1").Range("C" & lig) = Sheets(i).Range("C" & ligne)
            'copie NOMBRE D'HEURE
            Sheets("Feuil1").Range("D" & lig) = Sheets(i).Range("D" & ligne)
 
        End If
 
    Next Cel
 
Next i
 
End Sub
Sub Effacerlerécapitulatifdesformations()
'
' Effacerlerécapitulatifdesformations Macro
' Macro enregistrée le 21/09/2009
 
'
    Range("A5:D1467").Select
    Selection.ClearContents
    Range("A5").Select
End Sub
et
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
Sub Bouton3_QuandClic()
Dim NewSht As Worksheet, Sht As Worksheet, ws As Worksheet
Dim LastLig As Long, NewLig As Long
Dim NewShtName As String
Dim Trouve As Boolean
Dim Cel As Range
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
Set Sht = Sheets("feuil1")
With Sht
    LastLig = .Range("A65536").End(xlUp).Row
 
    For Each Cel In .Range("A3:A" & LastLig)
        Trouve = False
        NewShtName = Cel.Value
        For Each ws In Worksheets
            If ws.Name = NewShtName Then
                Trouve = True
                Exit For
            End If
        Next ws
 
        If Trouve Then
            Set NewSht = ws
        Else
            Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
            NewSht.Name = NewShtName
        End If
 
        NewLig = NewSht.Range("A65536").End(xlUp).Row + 1
        Cel.EntireRow.Copy NewSht.Cells(NewLig, 1)
    Next Cel
End With
 
Set Sht = Nothing
Set NewSht = Nothing
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub
 
Sub Bouton4_QuandClic()
Dim ws As Worksheet
 
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
 
 
    For Each ws In Worksheets
        If ws.Name <> "Feuil1" Then ws.Delete
    Next ws
 
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub