Discussion :

[Invité]

Bonjour à tous,
J'aurais besoin de vous pour me sortir d'un casse-tête

Dans un classeur , j'ai plusieurs onglets (étant variable) qui représente des noms de Stagiaire
Les feuilles sont identiques, seul les données changent

Je cherche le moyen de récupèrer le nom du Stagiaire qui se trouve en cellule D2
et ses differents stages se trouvant en cellules pouvant aller de D24 à D34 pour les dates et de F24 à F34 pour l'intitulé

Le tout allant dans une feuille "STAGE"

J'ai déjà ce bout de code:

Merci d'avance

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
Option Explicit
Sub Stages()
Dim i As Integer, j As Integer, k As Integer, lr As Integer, derligne As Integer, MaPlage As Range
For j = 1 To Worksheets.Count
    For k = 5 To 7
        If Worksheets(j).Name = Cells(k, 2).Value Then '(k,2= la liste des noms des onglets existant
            Sheets(j).Select
            derligne = Range("d35").End(xlUp).Row
            For i = 24 To derligne
                Sheets(j).Select
                Set MaPlage = Range("d" & i & ":f" & i) 'récupère de la colonne D à F, mais je voudrait ne pas avoir la colonne E
                MaPlage.Select
                Selection.Copy
 
                Sheets("Stage").Select
                lr = Range("b1000").End(xlUp).Row + 1
                Cells(lr, 2).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
            Next i
        End If
    Next k
Next j
Sheets("Stage").Select
End Sub

[Invité]

Re bonjour,

Bon, j'ai réussi jusque là à rappatrier mes données.
Le problème, c'est que si une fiche de stagiaire (Onglet) n'a pas de stage, la procèdure s'arrête et ne poursuit plus la recherche
Il y aurait-il une astuce pour lui dire que si dans la fiche sélectionné, la cellule D24 est vide, passer le chemin est continuer

Merci d'avance

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
Sub Stages()
Dim i As Integer, j As Integer, k As Integer, lr As Integer, derligne As Integer, MaPlage As Range
 
Sheets("Stage").Select
Range("a1").Select
Range("c6:L1000").ClearContents
For k = 5 To 100 Step 1
    For j = 1 To Worksheets.Count
        If Worksheets(j).Name = Cells(k, 2).Value Then '(k,2= la liste des noms des onglets existant
            Sheets(j).Select
 
            derligne = Range("d35").End(xlUp).Row
            For i = 24 To derligne
                Sheets(j).Select
                Sheets(j).Unprotect
 
                Set MaPlage = Range("d" & i & ":f" & i) 'récupère de la colonne D à F, mais je voudrait ne pas avoir la colonne E
                MaPlage.Select
                Selection.Copy
                Sheets("Stage").Select
                lr = Range("c1000").End(xlUp).Row + 1
                Cells(lr, 3).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
                     With Selection.Interior
                         .Pattern = xlNone
                         .TintAndShade = 0
                         .PatternTintAndShade = 0
                     End With
                         Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                         Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                         Selection.Borders(xlEdgeLeft).LineStyle = xlNone
                         Selection.Borders(xlEdgeTop).LineStyle = xlNone
                         Selection.Borders(xlEdgeBottom).LineStyle = xlNone
                         Selection.Borders(xlEdgeRight).LineStyle = xlNone
                         Selection.Borders(xlInsideVertical).LineStyle = xlNone
                         Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                Cells(lr, 12).Select
                Cells(lr, 12) = Cells(k, 2).Value
 
            Next i
 
        End If
    Next j
Next k
Sheets("Stage").Select
Range("a1").Select
End Sub

[Invité]

Bonjour,

Une solution possible avec ces codes présents dans le fichier joint : Pièce jointe 197561

Attention : L'onglet STAGE est effacé à chaque lancement de la macro RemplirLOngletStage

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
 
Sub RemplirLOngletStage()
 
Dim J As Long
Dim Continuer As Boolean
 
Dim ShOnglets As Worksheet
Dim PremiereLigneOnglets As Long
Dim DerniereLigneOnglets As Long
Dim AireOnglets As Range
Dim CelluleOnglets As Range
 
Dim ShStagiaire As Worksheet
Dim ShStages As Worksheet
 
     Set ShStages = Sheets("STAGE")
     With ShStages
          .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).Clear
     End With
 
     Set ShOnglets = Sheets("Liste des stagiaires")  ' A modifier, c'est l'onglet où s'applique la variable k dans votre code
 
     With ShOnglets
 
         ' Set AireOnglets = .Range(.Cells(5, 2), .Cells(7, 2))  ' 7 doit sans doute être modifié,
                                                                ' il vaudrait mieux trouver automatiquement la dernière ligne
 
          PremiereLigneOnglets = 5
          DerniereLigneOnglets = .Cells(.Rows.Count, 2).End(xlUp).Row
 
          If DerniereLigneOnglets < PremiereLigneOnglets Then
             MsgBox "Aucun onglet stagiaire, fin de programme", vbCritical, "Contrôle présence onglets stagiaires dans liste des onglets"
             Exit Sub
          End If
 
          Set AireOnglets = .Range(.Cells(5, 2), .Cells(DerniereLigneOnglets, 2))
 
 
          For Each CelluleOnglets In AireOnglets
              Continuer = False
              Set ShStagiaire = Nothing
              For J = 1 To Worksheets.Count
                  If Worksheets(J).Name = CelluleOnglets Then
                     Set ShStagiaire = Worksheets(J)
                     Continuer = True
                     Exit For
                  End If
              Next J
              If Continuer = True Then
                 RecenserLesStages ShStagiaire, ShStages
              End If
          Next CelluleOnglets
 
          Set AireOnglets = Nothing
 
     End With
 
     With ShStages
          .Activate
          .Columns(2).HorizontalAlignment = xlCenter
     End With
 
 
     Set ShStagiaire = Nothing
     Set ShOnglets = Nothing
     Set ShStages = Nothing
 
End Sub
 
 
Sub RecenserLesStages(ByVal FeuilleStagiaire As Worksheet, ByVal FeuilleStages As Worksheet)
 
Dim AireStagesStagiaire As Range
Dim CelluleStagesStagiaire As Range
 
Dim DerniereLigneStagesStagiaire As Long
Dim DerniereLigneStages As Long
 
Dim NomDuStagiaire As String
 
    With FeuilleStagiaire
 
         NomDuStagiaire = .Cells(2, 4)
         DerniereLigneStagesStagiaire = .Cells(35, 4).End(xlUp).Row
         If DerniereLigneStagesStagiaire >= 24 Then
            Set AireStagesStagiaire = .Range(.Cells(24, 4), .Cells(DerniereLigneStagesStagiaire, 4))
            For Each CelluleStagesStagiaire In AireStagesStagiaire
                If CelluleStagesStagiaire <> "" Then
                    With FeuilleStages
                         DerniereLigneStages = .Cells(.Rows.Count, 1).End(xlUp).Row
                         .Cells(DerniereLigneStages + 1, 1) = NomDuStagiaire
                         With .Cells(DerniereLigneStages + 1, 2)
                               .Value = CelluleStagesStagiaire
                               .NumberFormat = "dd/mm/yyyy"
                         End With
                         .Cells(DerniereLigneStages + 1, 3) = CelluleStagesStagiaire.Offset(0, 2)
                    End With
                End If
            Next CelluleStagesStagiaire
            Set AireStagesStagiaire = Nothing
         End If
 
    End With
 
End Sub

Cordialement.

[Invité]

Encore Merci, c'est impeccable !