Recopier tableau

lynyrd · 22 Décembre 2007

Boujour à tous
Est ce faisable à partir d'un bouton affecté à une macro de recopier un tableau pour les mois suivants en omettant les Dimanches et jours féries .
Merci .

JNP · 22 Décembre 2007

Re : Recopier tableau

Bonjour Lynyrd 🙂,
En faisant une boucle pour remplir la date de tout les mois, tu peux ôter les dimanches avec ce test :

Code:

If Weekday([COLOR=blue]TaDate[/COLOR]) = 1 Then
[COLOR=red]' passer au jour suivant[/COLOR]
End If

Ensuite, pour les fériés, tu as l'excellente fonction de Frédéric Sigorneau que l'on m'a transmise sur ce forum et que tu peux appeler en faisant une boucle comme celle-ci :

Code:

Dim Année As Integer, JoursFériésAnnée
Année = Year([COLOR=blue]TaDate[/COLOR])
JoursFériésAnnée = JoursFériés(Année)
Dim J As Integer
For J = LBound(JoursFériésAnnée) To UBound(JoursFériésAnnée)
If [COLOR=blue]TaDate[/COLOR] = FormatDateTime(JoursFériésAnnée(J)) Then
[COLOR=red]' passer au jour suivant[/COLOR]
End If
Next J

Et donc la fonction :

Code:

Function JoursFériés(An)
[COLOR=seagreen]' Détermination perpétuelle des jours fériés par année - Résultats sous forme de tableau[/COLOR]
[COLOR=seagreen]' Frédéric Sigoneau[/COLOR]
Dim NbOr, Epacte, Ajust As Integer
Dim PLune, LPaques, Arr(10) As Long
If ActiveWorkbook.Date1904 Then Ajust = 1462
[COLOR=seagreen] 'calcul du Lundi de Pâques[/COLOR]
  NbOr = (An Mod 19) + 1
  Epacte = (11 * NbOr - (3 + Int(2 + Int(An / 100)) * 3 / 7)) Mod 30
  PLune = DateSerial(An, 4, 19) - ((Epacte + 6) Mod 30)
  If Epacte = 24 Then PLune = PLune - 1
  If Epacte = 25 And (An >= 1900 And An < 2200) Then PLune = PLune - 1
  LPaques = PLune - Weekday(PLune) + vbMonday + 7        [COLOR=seagreen]'Lundi Pâques[/COLOR]
[COLOR=seagreen] 'tableau des fériés[/COLOR]
  Arr(0) = DateSerial(An, 1, 1) - Ajust
  Arr(1) = LPaques - Ajust
  Arr(2) = LPaques + 38 - Ajust  [COLOR=seagreen]'Ascension[/COLOR]
  Arr(3) = LPaques + 49 - Ajust  [COLOR=seagreen]'Pentecôte[/COLOR]
  Arr(4) = DateSerial(An, 5, 1) - Ajust
  Arr(5) = DateSerial(An, 5, 8) - Ajust
  Arr(6) = DateSerial(An, 7, 14) - Ajust
  Arr(7) = DateSerial(An, 8, 15) - Ajust
  Arr(8) = DateSerial(An, 11, 1) - Ajust
  Arr(9) = DateSerial(An, 11, 11) - Ajust
  Arr(10) = DateSerial(An, 12, 25) - Ajust
  [COLOR=seagreen]'tri du tableau[/COLOR]
  Dim I%, J%, K%, tmp
  For I = LBound(Arr) To UBound(Arr)
    J = I
    For K = J + 1 To UBound(Arr)
      If Arr(K) <= Arr(J) Then J = K
    Next K
    If I <> J Then
      tmp = Arr(J): Arr(J) = Arr(I): Arr(I) = tmp
    End If
  Next I
 [COLOR=seagreen] 'renvoi du résultat[/COLOR]
  On Error GoTo Fin
  If Application.Caller.Rows.Count > 1 Then
    JoursFériés = Application.Transpose(Arr)
    Exit Function
  End If
Fin:
  JoursFériés = Arr
End Function 'fs

A te lire 😎

Kotov · 22 Décembre 2007

Re : Recopier tableau

Bonjour Lynyrd, JPN,

JPN m'a devancé mais comme j'ai passé un peu de temps sur cette demande, je propose une possibilité quelque peu différente :

Code:

Const y = 2008
'Les fériés
Const F1 = #1/1/2008#
Const F2 = #3/24/2008#
Const F3 = #5/1/2008#
Const F4 = #5/8/2008#
Const F5 = #5/12/2008#
Const F6 = #7/14/2008#
Const F7 = #8/15/2008#
Const F8 = #11/1/2008#
Const F9 = #11/11/2008#
Const F10 = #12/25/2008#

Private Sub cmbCalendrier_Click()
Mobi
End Sub


Sub Mobi()
Dim m As Byte
Dim r%
Dim i As Byte
Dim d As Date


r = ActiveSheet.Cells(65536, 1).End(3).Row + 1

For m = 1 To 12
Select Case m
    Case 1, 3, 5, 7, 8, 10, 12
    
        For i = 1 To 31
        d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S1
            End Select
                
                If Weekday(d) = vbSaturday Or Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
            
S1:
        Next i
        
    Case 4, 6, 9, 11
        For i = 1 To 30
        d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S2
            End Select
               
                If Weekday(d) = vbSaturday Or Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
           
S2:
        Next i
    Case 2
     Select Case y
     Case 2008, 2012, 2016, 2020
            For i = 1 To 29
            d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S3
            End Select
               
                If Weekday(d) = vbSaturday Or Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
         
S3:
        Next i
    Case Else
            For i = 1 To 28
            d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S4
            End Select
               
                If Weekday(d) = vbSaturday Or Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
           
S4:
        Next i
    End Select
End Select

Next m

End Sub

Je te joins ton fichier avec ma proposition.
Vas dans la feuille Test, cliques sur le bouton "Calendrier" et tu disposeras de toute l'année à l'exception des fériés, des samedi et dimanche.

Je te laisse le soin de la mise en page

Bonne journée
Kotov

Kotov · 22 Décembre 2007

Re : Recopier tableau

Re,

Ma macro élimine les samedi,les dimanche et les jours fériés, or je m'aperçois que tu souhaites conserver les samedi.

Pour n'éliminer que les dimanche, remplace les lignes
If Weekday(d) = vbSaturday Or Weekday(d) = vbSunday Then

par
If Weekday(d) = vbSunday Then

Tu as 4 changements à faire.

Pour info, sachant que le dimanche correspond au 1, le lundi au 2, etc.., il est également possible d'écrire
If Weekday(d) = 1 Then

Bonne journée
Kotov

JNP · 22 Décembre 2007

Re : Recopier tableau

Bonjour Kotov 🙂,
C'est souvent que lorsque je poste ma réponse, ben, "trottoir", quelqu'un est déjà passé 😱. Mais c'est super constructif. J'avais décrit les tests, toi l'écriture dans le fichier, si Lynyrd charge dans tes constantes le tableau des fériés perpétuels, il va se retrouver avec une RollsRoyce 😀
Joyeuses fêtes à tous 😎

lynyrd · 22 Décembre 2007

Re : Recopier tableau

Merci les gars
Bonne fin d'année

Kotov · 22 Décembre 2007

Re : Recopier tableau Jours sans fériés ni dimanche

Re Lynyrd, JPN,

@ JPN : bien sûr que c'est intéressant d'être complémentaire. Avec la fonction "Fériés perpétuels" de F. Sigoneau que tu proposes, Lynyrd est paré pour un moment !

@ Lynyrd :
Ma macro est valable pour 2008. Pour les années suivantes, tu devras changer les constantes :
y=2009, les fériés F1 à F10 (notes bien le format date)
Autre option, intégrer une bonne fois pour toute la fonction proposée par JPN. Là, il faudra apporter quelques légères modifications à ma macro.
N'hésites pas à demander de l'aide en cas de besoin.

Bon Noël à tous

Kotov

lynyrd · 22 Décembre 2007

Re : Recopier tableau

Merci kotov
Mais je connais rien a VBA
Dans la macro que tu as faite,lorsque l'on clique sur le bouton affecté à la macro,les dates s'affichent pour une année.
En fait ce que je recherche c'est que à chaque pression sur le bouton,le moi suivant s'affiche en gardant les entêtes (3 premiéres lignes du tableau) avec le mois qui change .
Est ce possible?
Encore merci pour ton travail.

Kotov · 23 Décembre 2007

Re : Recopier tableau

Bonjour Lynyrd,
On peut bien évidement intégrer automatiquement les entêtes de lignes au début de chaque mois.

Dans une optique pédagogique, je joins la macro et le fichier qui correspondent à tes besoins.
Je te laisse le soin de la mise en forme, sachant qu'on peut également l'intéger dans la macro.

Abordons maintenant le côté pratique :
Est ce bien le plus efficace ? Personnellement, même si je connais VBA, j'aurais simplement utilisé la méthode manuelle.
Cela m'aurait pris moins de temps que le développement de la macro :
- saisie (une seule fois) des entêtes, mise en forme, puis copie et insertion en début de chaque mois
Tout faire en VBA, c'est bon pour le "fun", mais comme dirait un membre de ce forum, c'est "tuer une mouche au bazooka" !

Si tu n'as besoin que d'un calendrier par an, c'est plus efficace de le faire en manuel.
Et si tu dois le diffuser à plusieurs personnes, une simple copie suffit.

Faire simple, il n'y a rien de tel !

Je te souhaite un joyeux Noël

Kotov

Code:

Const y = 2008
'Les fériés
Const F1 = #1/1/2008#
Const F2 = #3/24/2008#
Const F3 = #5/1/2008#
Const F4 = #5/8/2008#
Const F5 = #5/12/2008#
Const F6 = #7/14/2008#
Const F7 = #8/15/2008#
Const F8 = #11/1/2008#
Const F9 = #11/11/2008#
Const F10 = #12/25/2008#

Private Sub cmbCalendrier_Click()
Mobi
End Sub


Sub Mobi()
Dim m As Byte
Dim r%
Dim i As Byte
Dim d As Date
Dim Mois As Date


r = ActiveSheet.Cells(65536, 1).End(3).Row + 1

For m = 1 To 12
[color=blue]
Mois = "01/" & m & "/" & y
Cells(r, 1) = Format(Mois, "mmmm") & " " & y: r = r + 1
Cells(r, 1) = "Est-ce que j'ai appelé ?": r = r + 1
Cells(r, 1) = "Jours"
Cells(r, 2) = "Prénom"
Cells(r, 3) = "Oui"
Cells(r, 4) = "Oui, mais trop tard"
Cells(r, 5) = "Non, pourquoi ?": r = r + 1
[/color]
Select Case m
    Case 1, 3, 5, 7, 8, 10, 12
    
        For i = 1 To 31
        d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S1
            End Select
                
                If Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
            
S1:
        Next i
        
    Case 4, 6, 9, 11
        For i = 1 To 30
        d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S2
            End Select
               
                If Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
           
S2:
        Next i
    Case 2
     Select Case y
     Case 2008, 2012, 2016, 2020
            For i = 1 To 29
            d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S3
            End Select
               
                If Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
         
S3:
        Next i
    Case Else
            For i = 1 To 28
            d = CDate(i & "/" & m & "/" & y)
            Select Case d
            Case F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
                GoTo S4
            End Select
               
                If Weekday(d) = vbSunday Then
                Else
                    Cells(r, 1) = d
                    r = r + 1
                End If
           
S4:
        Next i
    End Select
End Select

Next m

End Sub

lynyrd · 23 Décembre 2007

Re : Recopier tableau

Merci KOTOV,c'est impeccable .
Joyeux Noël .

Recopier tableau

lynyrd

XLDnaute Impliqué

Pièces jointes

JNP

XLDnaute Barbatruc

Kotov

XLDnaute Impliqué

Pièces jointes

Kotov

XLDnaute Impliqué

JNP

XLDnaute Barbatruc

lynyrd

XLDnaute Impliqué

Kotov

XLDnaute Impliqué

lynyrd

XLDnaute Impliqué

Kotov

XLDnaute Impliqué

Pièces jointes

lynyrd

XLDnaute Impliqué

Discussions similaires

Recopier tableau

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

Pièces jointes

XLDnaute Impliqué

Discussions similaires

Privacy & Transparency

Privacy & Transparency