Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Christian0258 · 14 Avril 2016

Bonjour à tout le forum,

Je souhaiterais, à nouveau, votre aide pour adapter un code de job75.

Ce code fonctionne sur d'autres fichiers, mais je n'arrive pas à l'adapter à mon fichier...

voir fichier.

Merci pour le temps que vous voudrez bien vouloir m'accorder.
Bien amicalement,
Christian

job75 · 14 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Bonsoir Christian,

Si tu connais le fil où j'ai créé cette macro ça ne doit pas être bien difficile d'adapter.

Sinon pas envie de me casser la tête à la déchiffrer.

A+

Christian0258 · 14 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re, le forum, job75,

Merci quand même , job75.
sinon ; le fil

https://www.excel-downloads.com/thr...-les-envoyer-sur-une-feuille-conges-i.223088/

Bien à toi,
Christian

job75 · 14 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re,

L'adaptation de la macro n'est pas simple, je n'irai pas plus loin.

Bonne nuit.

Christian0258 · 15 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re, le forum, job75,

OK, j'ai bien noté. En tout cas, merci job75, pour tout ce que tu fais sur ce forum.

Bien à toi.

Christian

job75 · 15 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Bonjour Christian, le forum,

J'étais très occupé hier soir et ce matin, mais j'ai trouvé un peu de temps.

Le code de la feuille "Planning" :

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C13].CurrentRegion) Is Nothing Then Exit Sub
Dim a, fer As Range, numero&, nom$, F As Worksheet, P As Range, sup As Range, i&, t, ub%, n&, rest()
a = Array("CA", "RTT", "CA/HP", "CA/FR", "(CA)", "(RTT)", "(CA/HP)", "(CA/FR)") 'liste à adapter
Set fer = [Feries]
numero = Application.Max(Sheets("Congés").[A:A]) + 1 'nécessaire pour la MFC
nom = Target
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
F.Parent.Date1904 = ThisWorkbook.Date1904 'calendrier
F.[A1].Resize(, 31) = [F11].Resize(, 31).Value 'adapter éventuellement
F.[A2].Resize(, 31) = Target(16, 4).Resize(, 31).Value 'adapter éventuellement
Set P = F.UsedRange
'---suppression des week-ends et jours fériés---
Set sup = Nothing
For i = 1 To 31
  If Weekday(P(1, i), 2) > 5 Or Application.CountIf(fer, P(1, i)) _
    Then Set sup = Union(P(1, i), IIf(sup Is Nothing, P(1, i), sup))
Next i
If Not sup Is Nothing Then sup.EntireColumn.Delete
'---analyse des congés---
t = P.Value2 'matrice, plus rapide
ub = UBound(t, 2)
For i = 1 To ub
  If IsNumeric(Application.Match(t(2, i), a, 0)) Then
    n = n + 1
    ReDim Preserve rest(1 To 5, 1 To n)
    rest(1, n) = numero
    rest(2, n) = nom
    rest(3, n) = t(1, i)
    Do
      i = i + 1
      If i > ub Then Exit Do
    Loop While t(2, i) = t(2, i - 1)
    i = i - 1
    rest(4, n) = t(1, i)
    rest(5, n) = t(2, i)
  End If
Next i
F.Parent.Close False 'suppression du nouveau document
'---restitution---
If n Then
  With Sheets("Congés")
    i = .Range("A" & .Rows.Count).End(xlUp)(2).Row
    .Cells(i, 1).Resize(n, 5) = Application.Transpose(rest) 'maximum 65536 lignes
    .Cells(i, 6).Resize(n) = "=RC[-2]-RC[-3]+1"
    .Cells(i, 7).Resize(n) = "=NETWORKDAYS(RC[-4],RC[-3],Feries)"
    .Activate
  End With
End If
End Sub

Fichier joint.

A+

Christian0258 · 15 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Bonjour le forum, job75,

Je rentre, et je trouve ce travail de job75.

Que dire...un grand merci, pour ce gros et beau boulot....

Encore merci, salut l'artiste.

Bien à toi,
Christian

job75 · 15 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re,

C'est curieux que je n'y ai pas pensé sur l'autre fil.

Ceci est bien plus simple, plus besoin d'un document auxiliaire :

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C13].CurrentRegion) Is Nothing Then Exit Sub
Dim a, fer As Range, numero&, nom$, horaires, conges, i&, t(), ub%, n&, rest()
a = Array("CA", "RTT", "CA/HP", "CA/FR", "(CA)", "(RTT)", "(CA/HP)", "(CA/FR)") 'à adapter
Set fer = [Feries]
numero = Application.Max(Sheets("Congés").[A:A]) + 1 'nécessaire pour la MFC
nom = Target
horaires = [F11].Resize(, 31).Value2 'adapter éventuellement
conges = Target(16, 4).Resize(, 31) 'adapter éventuellement
'---tableau de base sans week-ends et jours fériés---
ub = 0
ReDim t(1 To 2, 1 To 31)
For i = 1 To 31
  If Weekday(horaires(1, i), 2) < 6 And Application.CountIf(fer, horaires(1, i)) = 0 _
    Then ub = ub + 1: t(1, ub) = horaires(1, i): t(2, ub) = conges(1, i)
Next i
'---analyse des congés---
For i = 1 To ub
  If IsNumeric(Application.Match(t(2, i), a, 0)) Then
    n = n + 1
    ReDim Preserve rest(1 To 5, 1 To n)
    rest(1, n) = numero
    rest(2, n) = nom
    rest(3, n) = t(1, i)
    Do
      i = i + 1
      If i > ub Then Exit Do
    Loop While t(2, i) = t(2, i - 1)
    i = i - 1
    rest(4, n) = t(1, i)
    rest(5, n) = t(2, i)
  End If
Next i
'---restitution---
If n Then
  With Sheets("Congés")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    i = .Range("A" & .Rows.Count).End(xlUp)(2).Row
    .Cells(i, 1).Resize(n, 5) = Application.Transpose(rest) 'maximum 65536 lignes
    .Cells(i, 6).Resize(n) = "=RC[-2]-RC[-3]+1"
    .Cells(i, 7).Resize(n) = "=NETWORKDAYS(RC[-4],RC[-3],Feries)"
    .Activate
  End With
End If
End Sub

Et le visuel est bien meilleur, pas de saut d'écran.

Edit : ajouté If .FilterMode Then .ShowAllData 'si la feuille est filtrée

Fichier (2).

A+

Christian0258 · 16 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re, le forum, job75,

Merci, job75, pour cette version encore plus affinée.

Dis moi, si je clique plusieurs fois sur le même nom, j'ai autant de fois les congés qui "s'empilent"....

Il peut être nécessaire de cliquer plusieurs fois sur un même nom (exemple pour une annulation ou un changement de dates de congés. Pour ces cas de figures, il serait bien d'écraser les précédentes données et non de les mettre à la suite...
Est-ce possible

Merci pour tout.
Bien à toi,
Christian

job75 · 16 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Bonjour Christian,

Je ne pense pas que ce soit une bonne solution d'écraser un transfert de congés.

Alors qu'il suffit d'aller dans la feuille "Congés" pour supprimer toutes les lignes avec le même numéro.

C'est même pour cela que j'ai mis 2 couleurs pour la MFC.

Mais en effet il faut alors refaire une nouvelle numérotation avec cette macro dans la feuille "Congés" :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
'renumérote la colonne A
If Intersect(Target, [A:A]) Is Nothing Or [A3] = "" Then Exit Sub
Dim P As Range, t(), i&, n&
If FilterMode Then ShowAllData
Set P = Range("A3", Range("A" & Rows.Count).End(xlUp))
ReDim t(1 To P.Rows.Count, 1 To 2) 'au moins 2 éléments
For i = 1 To UBound(t)
  If P(i) <> P(i - 1) Then n = n + 1
  t(i, 1) = n
Next
Application.EnableEvents = False: P = t: Application.EnableEvents = True
End Sub

Fichier (3).

Bonne journée.

Christian0258 · 16 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re, le forum, job75

Ok, tu as peut-être raison, pour l'écrasement ou non des congés ?...

Ta solution me va bien.

Encore un grand merci.
Bien à toi,
Christian

job75 · 16 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re,

Avec 2 boutons pour effacer :

Code:

Private Sub CommandButton1_Click() 'le dernier transfert
Application.EnableEvents = False
With Range("A3:A" & Rows.Count)
  .Replace Application.Max(.Cells), " "
  On Error Resume Next
  .SpecialCells(xlCellTypeConstants, 2).Resize(, 7).ClearContents
End With
Application.EnableEvents = True
End Sub

Private Sub CommandButton2_Click() 'tous les transferts
Range("A3:G" & Rows.Count).ClearContents
End Sub

Fichier (4).

A+

Christian0258 · 16 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re, le forum, job75,

Oui, très bien, cette version "bouton".
Un grand merci.

Bien à toi,
Christian

Christian0258 · 17 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Re, le forum, job75,

Je n'avais pas fait attention, mais après plusieurs vérifs...les congés ne sont pas récupérés comme "prévu"...

voir explications fichier joint

Merci pour votre aide.
Bien amicalement,
Christian

job75 · 17 Avril 2016

Re : Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

Bonjour Christian,

En effet avec le Calendrier 1904 il faut faire une conversion pour le Weekday :

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C13].CurrentRegion) Is Nothing Then Exit Sub
Dim a, fer As Range, numero&, nom$, dates, conges, t(), i&, wd, ub%, n&, rest()
a = Array("CA", "RTT", "CA/HP", "CA/FR", "(CA)", "(RTT)", "(CA/HP)", "(CA/FR)") 'à adapter
Set fer = [Feries]
numero = Application.Max(Sheets("Congés").[A:A]) + 1 'nécessaire pour la MFC
nom = Target
dates = [F11].Resize(, 31).Value2 'adapter éventuellement
conges = Target(16, 4).Resize(, 31) 'adapter éventuellement
'---tableau de base sans week-ends et jours fériés---
ReDim t(1 To 2, 1 To 31)
For i = 1 To 31
  wd = Weekday(dates(1, i) + IIf(ThisWorkbook.Date1904, 1462, 0), 2)
  If wd < 6 And Application.CountIf(fer, dates(1, i)) = 0 _
    Then ub = ub + 1: t(1, ub) = dates(1, i): t(2, ub) = conges(1, i)
Next i
'---analyse des congés---
For i = 1 To ub
  If IsNumeric(Application.Match(Trim(t(2, i)), a, 0)) Then
    n = n + 1
    ReDim Preserve rest(1 To 5, 1 To n)
    rest(1, n) = numero
    rest(2, n) = nom
    rest(3, n) = t(1, i)
    Do
      i = i + 1
      If i > ub Then Exit Do
    Loop While t(2, i) = t(2, i - 1)
    i = i - 1
    rest(4, n) = t(1, i)
    rest(5, n) = t(2, i)
  End If
Next i
'---restitution---
If n Then
  With Sheets("Congés")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    i = .Range("A" & .Rows.Count).End(xlUp)(2).Row
    .Cells(i, 1).Resize(n, 5) = Application.Transpose(rest) 'maximum 65536 lignes
    .Cells(i, 6).Resize(n) = "=RC[-2]-RC[-3]+1"
    .Cells(i, 7).Resize(n) = "=NETWORKDAYS(RC[-4],RC[-3],Feries)"
    .Activate
  End With
End If
End Sub

Fichier (5).

A+

Modifier cette macro pour incrémenter une feuille "Congés", macro de job75

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums