Temp partiel dans calendrier

Le 20/02/2016 à 21:18

Bonjour le forum.

Je suis un peux perdu j'ai un planning ou je peut rentrer des infos et une feuille paramètre ou sont rentrer les info de temps partiel.

je cherche a remplir automatiquement les jours de Temps partiel dans le calendrier .

si joint mon Fichier test

32test-planning.xlsm (64.91 Ko)
Le 21/02/2016 à 08:31

Bonjour,

on doit pouvoir optimiser le code et la structure des infos, mais cela fonctionne !

Sub Bouton17_Clic()
' Application.Weekday(Date, 2)
Dim Cherche1 As Range, cherche2 As Range
With Sheets("Parametres")
    For i = 10 To Range("D" & Application.Rows.Count).End(xlUp).Row
        If Range("D" & i) <> "" Then
            Set Cherche1 = .Columns("F").Find(Range("D" & i), .Range("F" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
            If Not Cherche1 Is Nothing Then
                If Cherche1.Offset(0, 1) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 1), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                Cells(i, j + 5) = "TP"
                            End If
                        Next j
                    End If
                End If
                If Cherche1.Offset(0, 2) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 2), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                Cells(i + 1, j + 5) = "TP"
                            End If
                        Next j
                    End If
                End If
                If Cherche1.Offset(0, 3) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 3), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                Cells(i, j + 5) = "TP"
                                Cells(i + 1, j + 5) = "TP"
                            End If
                        Next j
                    End If
                End If
            End If
        End If
    Next
End With

End Sub
9test-planning.xlsm (68.41 Ko)
Le 21/02/2016 à 08:48

Correction pour les mois < 31 jours !

Sub Bouton15_Clic()
a = MsgBox("Etes-vous sûr de vouloir effacer le planning ?", vbYesNo, "RAZ")
If a = 6 Then
Range("E10:AI31").ClearContents
Range("E34:AI90").ClearContents
Range("E93:AI124").ClearContents
End If
End Sub

Sub Bouton16_Clic()
a = InputBox("Veuillez indiquer un nom pour la sauvegarde de ce planning", "Sauvegarde", Range("N6"))
If a <> "" Then
Sheets("Planning").Copy Before:=Sheets(1)
Sheets(1).Name = a
End If
End Sub

Sub Bouton17_Clic()
Dim Cherche1 As Range, cherche2 As Range
With Sheets("Parametres")
    For i = 10 To Range("D" & Application.Rows.Count).End(xlUp).Row
        If Range("D" & i) <> "" Then
            Set Cherche1 = .Columns("F").Find(Range("D" & i), .Range("F" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
            If Not Cherche1 Is Nothing Then
                If Cherche1.Offset(0, 1) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 1), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Cells(9, j + 5) <> "" Then
                                If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                    Cells(i, j + 5) = "TP"
                                End If
                            End If
                        Next j
                    End If
                End If
                If Cherche1.Offset(0, 2) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 2), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Cells(9, j + 5) <> "" Then
                                If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                    Cells(i + 1, j + 5) = "TP"
                                End If
                            End If
                        Next j
                    End If
                End If
                If Cherche1.Offset(0, 3) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 3), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Cells(9, j + 5) <> "" Then
                                If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                    Cells(i, j + 5) = "TP"
                                    Cells(i + 1, j + 5) = "TP"
                                End If
                            End If
                        Next j
                    End If
                End If
            End If
        End If
    Next
End With

End Sub
10test-planning.xlsm (68.84 Ko)
Le 21/02/2016 à 10:05

Bonjour à tous

Une autre approche :

Bye !

12test-planning-v1.xlsm (69.55 Ko)
Le 21/02/2016 à 11:46

Code beaucoup plus joli que le mien ... mais il me plante à chaque fois ! Pas compris pourquoi.

Le 21/02/2016 à 13:46

Bonjour Steelson

A choisir, et sans l'ombre d'une hésitation, je préfère un code plus efficace à un code plus joli !

En fait, il y avait bien un bug. Merci de ton intervention.

Cette nouvelle version devrait mieux marcher.

Bye !

11test-planning-v2.xlsm (70.31 Ko)
Le 21/02/2016 à 13:54

Salut gmb ... cela tourne en boucle, je ne sais pas pourquoi ! j'ai ajouté jeudi matin à Hocine ... Gilles n'est plus pris en compte et le lundi d'Hocine disparaît ! Les temps partiels sur plusieurs jours ne sont pas courants mais j'en connais ...

Le 21/02/2016 à 14:09

bonjour et merci a vous deux

toutefois si je peux abuser pourriez vous m'expliquer le code pour que je puisse l'adapter a mon fichier.

en tout cas merci beaucoup.

Le 21/02/2016 à 17:37

Est-ce suffisant ?

Sub Bouton17_Clic()
Dim Cherche1 As Range, cherche2 As Range

With Sheets("Parametres") ' tout ce qui commencera par "." fera référence à cette feuille Parametres

    For i = 10 To Range("D" & Application.Rows.Count).End(xlUp).Row
        ' pour toutes les valeurs non vides de la colonne D
        If Range("D" & i) <> "" Then

            Set Cherche1 = .Columns("F").Find(Range("D" & i), .Range("F" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
            ' je cherche une correspondance en D de la feuille Parametres et si la recherche n'est pas vide
            If Not Cherche1 Is Nothing Then

                If Cherche1.Offset(0, 1) <> "" Then
                ' je décale de 1 colonne et si elle n'est pas vide, alors TP un matin

                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 1), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    ' je cherche en colonne F de la feuille Parametres le jour
                    If Not cherche2 Is Nothing Then

                        ' je balaye le calendrier
                        For j = 1 To 31
                            If Cells(9, j + 5) <> "" Then

                                ' weekday = n° du jour (1= lundi etc.) qu je compare au jour trouvé (ligne-5 car le lundi est sur la 6ème ligne)
                                If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then

                                    ' j'indique TP
                                    Cells(i, j + 5) = "TP"
                                End If
                            End If
                        Next j
                    End If
                End If
                If Cherche1.Offset(0, 2) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 2), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Cells(9, j + 5) <> "" Then
                                If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                    Cells(i + 1, j + 5) = "TP"
                                End If
                            End If
                        Next j
                    End If
                End If
                If Cherche1.Offset(0, 3) <> "" Then
                    Set cherche2 = .Columns("L").Find(Cherche1.Offset(0, 3), .Range("L" & Application.Rows.Count).End(xlUp), xlValues, xlWhole)
                    If Not cherche2 Is Nothing Then
                        For j = 1 To 31
                            If Cells(9, j + 5) <> "" Then
                                If Application.Weekday(Cells(9, j + 5), 2) = cherche2.Row - 5 Then
                                    Cells(i, j + 5) = "TP"
                                    Cells(i + 1, j + 5) = "TP"
                                End If
                            End If
                        Next j
                    End If
                End If
            End If
        End If
    Next
End With

End Sub
Le 21/02/2016 à 18:24

Super merci

mais je ne comprend pas pourquoi cela ne fonctionne pas sur mon fichier

si une bonne âmes veux jeter un œil ce serais super.

14classeur1.xlsm (43.93 Ko)

Merci en tout cas a tous.

Le 21/02/2016 à 20:13

Voir les modifs ... compare le code pour voir ce qui a changé (de mémoire c'est la ligne des dates qui commence à la colonne 4 et non 5 et à la ligne 11 et non 9).

Dis moi si ok, n'hésite pas à demander des explications.

16classeur1.xlsm (43.77 Ko)
Le 22/02/2016 à 11:01

Re

je reviens vers vous car j'ai un souci sur la colonne D du fichier elle n'est pas prise en compte dans la saisie du TP

j'ai tester sur le mois d'avril ( le vendredi )

12planning-tp.xlsm (109.52 Ko)

MERCI ENCORE DE VOTRE AIDE.

Le 22/02/2016 à 13:18

A tester ... il y avait plusieurs schmilblicks.

20planning-tp.xlsm (93.73 Ko)
Le 22/02/2016 à 19:00

cool merci beaucoup

JE REVIENDRAIS

Rechercher des sujets similaires à "temp partiel calendrier"