Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

C

Christian0258

XLDnaute Accro
Bonjour à tout le forum,

Je souhaiterais votre aide sur une macro, afin de trouver des dates de congés sur un planning et les placer, dans un tableau sur une feuille (nommée Congés), avec leurs codes et leurs dates début/fin sans écraser les codes et dates déja placés dans cette feuille Congés...
Voir fichier

Je vous remercie pour votre aide.

Bien amicalement,
Christian
 

Pièces jointes

  • DatesCongésPlanningV02.zip
    99.7 KB · Affichages: 36
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Bonjour Christian, le forum,

J'ai préféré écrire mon propre code, pour moi c'est plus simple :

Code: 
Sub Liste()
Dim a, F1 As Worksheet, F2 As Worksheet, nlig&, P As Range, ncol%
Dim rest(), F As Worksheet, i&, Q As Range, sup As Range, j%, t, ub%, n&
a = Array("CA", "RTT", "CF", "CHS") 'liste à adapter, pas besoin des *
Set F1 = Feuil1 'CodeName de la feuille Planning
Set F2 = Feuil6 'CodeName de la feuille Congés
nlig = Application.Match("zzz", F1.[C:C]) - 10 'à adapter
If nlig < 2 Then GoTo 1
Set P = F1.Range(F1.[C11].Resize(nlig), F1.Cells(11, F1.Columns.Count).End(xlToLeft))
ncol = P.Columns.Count
ReDim rest(1 To nlig * ncol, 1 To 4)
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
For i = 2 To nlig
  '---tableau de 2 lignes---
  F.[A1].Resize(, ncol) = P.Rows(1).Value
  F.[A2].Resize(, ncol) = P.Rows(i).Value
  Set Q = F.[A1].Resize(2, ncol)
  '---suppression des colonnes inutiles---
  Set sup = Nothing
  For j = 2 To ncol
    If IsError(Application.Match(Q(2, j), a, 0)) _
      Then Set sup = Union(Q(2, j), IIf(sup Is Nothing, Q(2, j), sup))
  Next j
  If Not sup Is Nothing Then sup.EntireColumn.Delete
  '---nouvelle analyse---
  t = Q 'matrice, plus rapide
  ub = UBound(t, 2)
  For j = 2 To ub
    n = n + 1
    rest(n, 1) = t(2, 1)
    rest(n, 2) = t(1, j)
    Do
      j = j + 1
      If j > ub Then Exit Do
      If t(2, j) <> t(2, j - 1) Then Exit Do
    Loop
      j = j - 1
      rest(n, 3) = t(1, j)
      rest(n, 4) = t(2, j)
  Next j
Next i
F.Parent.Close False 'suppression du nouveau document
If n Then F2.[A3].Resize(n, 4) = rest 'restitution
1 F2.Range("A" & n + 3 & ":D" & F2.Rows.Count).ClearContents
F2.Activate 'facultatif
End Sub
Note qu'il est inutile de lister dans l'Array a les textes avec astérisque *.

Pour ta formule en Congés!F3 utilise :

Code: 
=SIGNE(B3*C3)*SI(E3="o";0,5;NB.JOURS.OUVRES(B3;C3;Feries))
Note aussi que je vais partir pour quelques jours en Bretagne.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re,

En fait, dans le tableau auxiliaire Q, il est préférable de supprimer uniquement les week-ends et jours fériés.

Autrement des périodes de congés disjointes peuvent se retrouver dans une seule période :

Code: 
Sub Liste()
Dim a, F1 As Worksheet, F2 As Worksheet, nlig&, P As Range, ncol%, rest()
Dim fer As Range, F As Worksheet, i&, Q As Range, sup As Range, j%, t, ub%, n&
a = Array("CA", "RTT", "CF", "CHS") 'liste à adapter, pas besoin des *
Set F1 = Feuil1 'CodeName de la feuille Planning
Set F2 = Feuil6 'CodeName de la feuille Congés
nlig = Application.Match("zzz", F1.[C:C]) - 10 'à adapter
If nlig < 2 Then GoTo 1
Set P = Intersect(F1.[C11].Resize(nlig, F1.Columns.Count - 2), F1.UsedRange)
ncol = P.Columns.Count
ReDim rest(1 To nlig * ncol, 1 To 4)
Set fer = [Férié]
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
For i = 2 To nlig
  '---tableau de 2 lignes---
  F.[A1].Resize(, ncol) = P.Rows(1).Value
  F.[A2].Resize(, ncol) = P.Rows(i).Value
  Set Q = F.[A1].Resize(2, ncol)
  '---suppression des week-ends et jours fériés---
  Set sup = Nothing
  For j = 2 To ncol
    If Weekday(Q(1, j), 2) > 5 Or Application.CountIf(fer, Q(1, j)) _
      Then Set sup = Union(Q(1, j), IIf(sup Is Nothing, Q(1, j), sup))
  Next j
  If Not sup Is Nothing Then sup.EntireColumn.Delete
  '---nouvelle analyse---
  t = Q 'matrice, plus rapide
  ub = UBound(t, 2)
  For j = 2 To ub
    If IsNumeric(Application.Match(t(2, j), a, 0)) Then
      n = n + 1
      rest(n, 1) = t(2, 1)
      rest(n, 2) = t(1, j)
      Do
        j = j + 1
        If j > ub Then Exit Do
        If t(2, j) <> t(2, j - 1) Then Exit Do
      Loop
      j = j - 1
      rest(n, 3) = t(1, j)
      rest(n, 4) = t(2, j)
    End If
  Next j
Next i
F.Parent.Close False 'suppression du nouveau document
If n Then F2.[A3].Resize(n, 4) = rest 'restitution
1 F2.Range("A" & n + 3 & ":D" & F2.Rows.Count).ClearContents
End Sub
A+
 
Vote positif 0 Vote négatif
C

Christian0258

XLDnaute Accro
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re, le forum, job75,

Ok, merci pour la dernière version.
Dis-moi, si je veux mettre à la file les résultats et non les écraser que faut-il adapter dans ta macro ?

A te lire.
Bien amicalement,
Christian
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re,

Ceci est beaucoup mieux car bien plus rapide :

Code: 
Sub Liste()
Dim a, F1 As Worksheet, F2 As Worksheet, nlig&, P As Range, ncol%, rest()
Dim fer As Range, F As Worksheet, Q As Range, j%, sup As Range, t, ub%, i&, n&
a = Array("CA", "RTT", "CF", "CHS") 'liste à adapter, pas besoin des *
Set F1 = Feuil1 'CodeName de la feuille Planning
Set F2 = Feuil6 'CodeName de la feuille Congés
nlig = F1.Range("C" & F1.Rows.Count).End(xlUp).Row - 10 'à adapter
If nlig < 2 Then GoTo 1
Set P = Intersect(F1.[C11].Resize(nlig, F1.Columns.Count - 2), F1.UsedRange)
ncol = P.Columns.Count
ReDim rest(1 To nlig * ncol, 1 To 4)
Set fer = [Férié]
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
F.Parent.Date1904 = ThisWorkbook.Date1904 'calendrier
F.[A1].Resize(nlig, ncol) = P.Value
Set Q = F.UsedRange
'---suppression des week-ends et jours fériés---
For j = 2 To ncol
  If Weekday(Q(1, j), 2) > 5 Or Application.CountIf(fer, Q(1, j)) _
  Then Set sup = Union(Q(1, j), IIf(sup Is Nothing, Q(1, j), sup))
Next j
If Not sup Is Nothing Then sup.EntireColumn.Delete
'---analyse des congés---
t = Q 'matrice, plus rapide
ub = UBound(t, 2)
For i = 2 To nlig
  For j = 2 To ub
    If IsNumeric(Application.Match(t(i, j), a, 0)) Then
      n = n + 1
      rest(n, 1) = t(i, 1)
      rest(n, 2) = t(1, j)
      Do
        j = j + 1
        If j > ub Then Exit Do
        If t(i, j) <> t(i, j - 1) Then Exit Do
      Loop
      j = j - 1
      rest(n, 3) = t(1, j)
      rest(n, 4) = t(i, j)
    End If
  Next j
Next i
F.Parent.Close False 'suppression du nouveau document
If n Then F2.[A3].Resize(n, 4) = rest 'restitution
1 F2.Range("A" & n + 3 & ":D" & F2.Rows.Count).ClearContents
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re,

Christian0258 à dit:
Dis-moi, si je veux mettre à la file les résultats et non les écraser que faut-il adapter dans ta macro ?
Cliquez pour agrandir...

Pas difficile, à la fin, au lieu de A3, il suffit de déterminer la cellule qui suit la dernière cellule avec End(xlUp)(2)

Mais je suppose que tu veux copier plusieurs feuilles de plannings.

A mon avis ce n'est pas une très bonne idée.

Il vaut mieux un seul planning, avec tous les mois qui se suivent, et cela sur plusieurs années.

C'est possible à partir d'Excel 2007 (16384 colonnes).

A+
 
Vote positif 0 Vote négatif
C

Christian0258

XLDnaute Accro
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re, le forum, job75,

Effectivement je veux copier plusieurs feuilles de plannings, ok vais étudier la question pour les mois qui se suivent...

Merci pour tout.

Bien à toi,
Christian
 
Vote positif 0 Vote négatif
C

Christian0258

XLDnaute Accro
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re, le forum, job75,

J'suis c.. je n'arrive pas à insérer End(xlUp)(2) au lieu de A3 :

If n Then F2.[A3].Resize(n, 4) = rest 'restitution
1 F2.Range("A" & n + 3 & ":D" & F2.Rows.Count).ClearContents
End Sub

à te lire,
Christian
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Bonjour Christian, le forum,

Après 5 jours d'absence.

Je viens de me rendre compte que tu utilises le calendrier 1904.

J'ai donc modifié la macro du post #6 pour que les jours fériés soient traités correctement :

Code: 
F.Parent.Date1904 = ThisWorkbook.Date1904 'calendrier
Maintenant pour traiter plusieurs feuilles "Planning" tu peux placer dans la feuille "Congés" :

Code: 
Private Sub Worksheet_Activate()
Dim a, fer As Range, F As Worksheet, w As Worksheet, nlig&, P As Range
Dim ncol%, Q As Range, sup As Range, j%, t, ub%, i&, n&, rest()
a = Array("CA", "RTT", "CF", "CHS") 'liste à adapter, pas besoin des *
Set fer = [Férié]
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
F.Parent.Date1904 = ThisWorkbook.Date1904 'calendrier
For Each w In ThisWorkbook.Worksheets
  If w.Name Like "Planning*" Then 'critère
    nlig = w.Range("C" & w.Rows.Count).End(xlUp).Row - 10 'à adapter
    If nlig > 1 Then
      F.UsedRange.Delete 'RAZ
      Set P = Intersect(w.[C11].Resize(nlig, w.Columns.Count - 2), w.UsedRange)
      ncol = P.Columns.Count
      F.[A1].Resize(nlig, ncol) = P.Value
      Set Q = F.UsedRange
      '---suppression des week-ends et jours fériés---
      Set sup = Nothing
      For j = 2 To ncol
        If Weekday(Q(1, j), 2) > 5 Or Application.CountIf(fer, Q(1, j)) _
          Then Set sup = Union(Q(1, j), IIf(sup Is Nothing, Q(1, j), sup))
      Next j
      If Not sup Is Nothing Then sup.EntireColumn.Delete
      '---analyse des congés---
      t = Q.Value2 'matrice, plus rapide
      ub = UBound(t, 2)
      For i = 2 To nlig
        For j = 2 To ub
          If IsNumeric(Application.Match(t(i, j), a, 0)) Then
            n = n + 1
            ReDim Preserve rest(1 To 4, 1 To n)
            rest(1, n) = t(i, 1)
            rest(2, n) = t(1, j)
            Do
              j = j + 1
              If j > ub Then Exit Do
              If t(i, j) <> t(i, j - 1) Then Exit Do
            Loop
            j = j - 1
            rest(3, n) = t(1, j)
            rest(4, n) = t(i, j)
          End If
        Next j
      Next i
      n = n + 1 'saut de ligne
    End If
  End If
Next w
F.Parent.Close False 'suppression du nouveau document
'---restitution---
If n Then
  ReDim Preserve rest(1 To 4, 1 To n)
  [A3].Resize(n, 4) = Application.Transpose(rest) 'maximum 65536 lignes
End If
Range("A" & n + 3 & ":D" & Rows.Count).ClearContents
End Sub
La feuille est mise à jour à chaque activation.

Fichier joint.

A+
 

Pièces jointes

  • DatesCongésPlanning(1).xlsm
    75.2 KB · Affichages: 41
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour trouver dates sur planning et les envoyer sur une feuille Congés...i

Re,

Une variante (2) avec une MFC (couleur de fond, bordures) en feuille "Congés".

La formule est entrée en colonne F par :

Code: 
  [F3].Resize(n).FormulaR1C1 = _
  "=SIGN(RC[-4]*RC[-3])*IF(RC[-1]=""o"",0.5,NETWORKDAYS(RC[-4],RC[-3],Férié))"
A+
 

Pièces jointes

  • DatesCongésPlanning(2).xlsm
    69.8 KB · Affichages: 54
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2016 Contrôle de la pose de 10 jours de congés consécutifs
Réponses
5
Affichages
347
djidji59430
djidji59430
N
  • Résolu(e)
XL 2016 Planning congés annuel
Réponses
4
Affichages
646
Noé71410
N
S
  • Question
Microsoft 365 Créer le nb de lignes contenues dans une période
Réponses
5
Affichages
320
Sampras63
S
T
  • Question
Microsoft 365 macro pour cacher dates sur calendrier excel
Réponses
9
Affichages
361
Tonio59160
T
P
  • Question
XL 2013 Recherche période de congés entre 2 dates
Réponses
1
Affichages
639
AC045364
A
chaelie2015
  • Résolu(e)
XL 2013 Gestion Automatisée des Dates en Fonction des Périodes et des Mois
Réponses
9
Affichages
527
Phil69970
Phil69970
M
  • Question
Microsoft 365 Question code VBA
Réponses
2
Affichages
120
Maxou69
M
L
  • Question
Microsoft 365 Mise en forme conditionnelle sur dates
Réponses
2
Affichages
462
Lou Janot
L
S
  • Question
Autres macro au ruban qui ajoute une feuille avec menu déroulant
Réponses
5
Affichages
416
Sirberthoult
S
K
  • Résolu(e)
XL 2019 tableau de bord
2
Réponses
22
Affichages
956
Lolote83
L

Membres actuellement en ligne

14 membres et 147 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 305
Messages
2 087 079
Membres
103 455
dernier inscrit
saramachado