VBA Compter le nombre de recurrences
Bonjour,
Je vous prie de m'aider à comprendre comment je pourrai mettre en place un contrôle spécifique.
J'ai un planning avec les différents créneaux.
Pour chaque personne, je dois compter le Nombre de créneaux
qui se terminent à 17h:
-> combien de fois par semaine?
-> combien de vendredis par mois?
Ci-joint, dans l'onglet Résultat vous vous pouvez voir le format attendu. Dans l'onglet "Planning" vous avez un exemple du planning.
Merci par avance pour votre aide.
Cordialement,
Bonjour,
essayez ceci
Sub Compter_17heures()
Dim f1 As Worksheet, f2 As Worksheet
Dim DerLig_f1 As Long, DerLig_f2 As Long, DerCol_f1 As Long, DerCol_f2 As Long, n As Long
Dim i As Long, j As Long, k As Long
Dim Cpt1 As Long, Cpt2 As Long
Dim Nom As String, Semaine As String
Application.ScreenUpdating = False
Set f1 = Sheets("Planning")
Set f2 = Sheets("Résultat")
DerLig_f1 = f1.Range("B" & Rows.Count).End(xlUp).Row
DerCol_f1 = f1.Range("XFD1").End(xlToLeft).Column
DerLig_f2 = f2.Range("B" & Rows.Count).End(xlUp).Row
DerCol_f2 = 9 'f1.Range("XFD1").End(xlToLeft).Column
Cpt1 = 0
For i = 2 To DerLig_f2
Nom = f2.Cells(i, "B")
'tous les jours de la semaine
For j = 3 To DerCol_f2 - 1
Semaine = Left(f2.Cells(1, j), 10)
For k = 5 To DerCol_f1
For n = 3 To DerLig_f1
If Left(f1.Cells(1, k), 10) = Semaine And f1.Cells(n, "B") = Nom Then
If InStr(1, f1.Cells(n, k), "17", 1) > 0 Then Cpt1 = Cpt1 + 1
End If
Next n
Next k
f2.Cells(i, j) = Cpt1
Cpt1 = 0
Next j
'tous les vendredis du mois
Cpt2 = 0
For k = 5 To DerCol_f1
For n = 3 To DerLig_f1
If Application.WorksheetFunction.Weekday(f1.Cells(2, k), 2) = 5 And f1.Cells(n, "B") = Nom Then
If InStr(1, f1.Cells(n, k), "17", 1) > 0 Then Cpt2 = Cpt2 + 1
End If
Next n
Next k
f2.Cells(i, 9) = Cpt2
Cpt2 = 0
Next i
f2.Select
Set f1 = Nothing
Set f2 = Nothing
End SubCdlt
Bonjour Arturo83:),
C'est super! ça marche parfaitement. Merci beaucoup. Deux petites questions:
1) d'un mois à l'autre, le vendredi n'est pas affiché dans la même case, son emplacement change...est-ce que c'est possible de détecter l'emplacement du vendredi en amont de l'exécution du macro?
2) c'est possible de copier-coller les deux premiers colonnes depuis le fichier planning en supprimant les doublons ?
Merci par avance...
Bonjour,
Excusez-moi, j'ai zappé votre post.
1) d'un mois à l'autre, le vendredi n'est pas affiché dans la même case, son emplacement change...est-ce que c'est possible de détecter l'emplacement du vendredi en amont de l'exécution du macro?, ça n'a pas d'importance puisque la macro lit la date sur les cellules de la ligne 2 et non ce qui est écrit manuellement(le jour) sur la ligne 1. Donc, même si les jours notés sur la ligne 1 sont faux, l'extraction sera toujours juste.
2) c'est possible de copier-coller les deux premiers colonnes depuis le fichier planning en supprimant les doublons ? Ok, c'est fait
Evitez de mette le jour ou la semaine en dur, il existe des formules qui se chargent de les calculer par rapport à la date, ça vous évitera de les changer manuellement à chaque changement de date.
Cdlt
Bonjour Arturo,
J'espère que tu vas bien.
Je reviens vers toi au sujet de ta macro qui marche super bien et qui me facilite vachement la vie.
Je tenais à te poser une question si tu peux m'aider à rajouter un bouton complémentaire qui ferait une opération suivante:
Si le résultat de calcul est supérieure à 1, alors, dans la feuille "Planning" effacer les cases qui font dépasser le compteur, en mettant par défaut 14h-16h.
L'objectif est qu'au final en cliquant sur le bouton "Calculer" chaque personne dans chaque case ait le chiffre 0 ou 1 maximum.
Merci par avance pour ton aide.
Cordialement,
Bonjour,
Essayez ceci:
Sub Compter_17heures()
Dim f1 As Worksheet, f2 As Worksheet
Dim DerLig_f1 As Long, DerLig_f2 As Long, DerCol_f1 As Long, DerCol_f2 As Long, n As Long
Dim i As Long, j As Long, k As Long, Col As Long
Dim Cpt1 As Long, Cpt2 As Long
Dim Nom As String, Semaine As String
Application.ScreenUpdating = False
Set f1 = Sheets("Planning")
Set f2 = Sheets("Résultat")
DerLig_f1 = f1.Range("B" & Rows.Count).End(xlUp).Row
DerCol_f1 = f1.Range("XFD1").End(xlToLeft).Column
DerLig_f2 = f2.Range("B" & Rows.Count).End(xlUp).Row
DerCol_f2 = 9 'f1.Range("XFD1").End(xlToLeft).Column
Cpt1 = 0
For i = 2 To DerLig_f2
Nom = f2.Cells(i, "B")
'tous les jours de la semaine
For j = 3 To DerCol_f2 - 1
Semaine = Left(f2.Cells(1, j), 10)
For k = 5 To DerCol_f1
For n = 3 To DerLig_f1
If Left(f1.Cells(1, k), 10) = Semaine And f1.Cells(n, "B") = Nom Then
If InStr(1, f1.Cells(n, k), "17", 1) > 0 Then Cpt1 = Cpt1 + 1
End If
Next n
Next k
f2.Cells(i, j) = Cpt1
Cpt1 = 0
Next j
'tous les vendredis du mois
Cpt2 = 0
For k = 5 To DerCol_f1
For n = 3 To DerLig_f1
If Application.WorksheetFunction.Weekday(f1.Cells(2, k), 2) = 5 And f1.Cells(n, "B") = Nom Then
If InStr(1, f1.Cells(n, k), "17", 1) > 0 Then Cpt2 = Cpt2 + 1
End If
Next n
Next k
f2.Cells(i, 9) = Cpt2
Cpt2 = 0
Next i
'Remplacer par 14h-16h les plages d'horaires tant que le compteur est supérieur à 1
For i = 2 To DerLig_f2
Nom = f2.Cells(i, "B")
'tous les jours de la semaine
For j = 3 To DerCol_f2
Semaine = Left(f2.Cells(1, j), 10)
cpt = f2.Cells(i, j)
With f1.Rows(1)
Set x = .Find(Semaine & "*", lookat:=xlPart)
If Not x Is Nothing Then
Col = x.Column
Do While Left(f1.Cells(1, Col), 10) = Left(x, 10) And cpt > 1
If InStr(1, f1.Cells(i + 1, Col), "17", 1) > 0 Then
f1.Cells(i + 1, Col) = "14h-16h"
cpt = cpt - 1
f2.Cells(i, j) = cpt
End If
Col = Col + 1
Loop
End If
End With
Next j
Next i
f2.Select
Set f1 = Nothing
Set f2 = Nothing
End SubCdlt