Micro challenge : la meilleure translation d'une formule

[Maxence HUBICHE]

Hello tous !

Dites, j'ai cherché et finallement réussi à trouver une formule dont je suis assez fier !
Sur Excel, ca donne :

Code :

1
2
 
'=ENT(($A35+(B$34-1))/7)*5-MIN(B$34-1;5)+MOD(SI(MOD(($A35+(B$34-1));7)=6;5;MOD(($A35+(B$34-1));7));6)

Cette formule calcul le nombre de jours ouvrables en fonction du nombre de jours du mois ($A35) et du jour de la semaine du jour 1 du mois considéré (B$34)

Qui se lance dans la réalisation de la fonction en VBA ?

La meilleure fonction sera celle qui donnera le meilleur temps en VBA pour 100 000 itérations !

[Maxence HUBICHE]

en voici une solution :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Function JoursOuvrables(NbJours As Byte, JourSem As Byte) As Byte
    'Déclaration des variables
    Dim bytNbJoursTotal        As Byte
    Dim bytNbJoursOuvrables    As Byte
    Dim bytNbJoursAOter        As Byte
    Dim bytNbJoursAAjouter     As Byte
    'Calcul des variables
    bytNbJoursAOter = JourSem - 1
    bytNbJoursTotal = NbJours + bytNbJoursAOter
    bytNbJoursAAjouter = IIf(bytNbJoursTotal Mod 7 = 6, 5, bytNbJoursTotal Mod 7) Mod 6
    bytNbJoursOuvrables = (bytNbJoursTotal \ 7) * 5
    'renvoi du résultat
    JoursOuvrables = bytNbJoursOuvrables + bytNbJoursAAjouter - IIf(bytNbJoursAOter < 5, bytNbJoursAOter, 5)
End Function

C'était juste pour lancer le challenge !
Qui fait mieux !
Allez ... j'attends les candidats


voici la fonction de test :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub testeur()
    Dim i   As Long
    Dim n1  As Byte
    Dim n2  As Byte
    Dim t   As Long
    t = Timer()
    For i = 1 To 100000
        n1 = CByte(Int(Rnd() * 4) + 28)
        n2 = CByte(Int(Rnd() * 7) + 1)
        Debug.Print n1 & vbTab & n2 & vbTab & JoursOuvrables(n1, n2)
    Next
    t = Timer() - t
    Debug.Print "Terminé : " & t
End Sub

Résultat chez moi :
Terminé : 27 - 91 - 288 (??? va falloir que je refasse les tests moi ... ???)

[SilkyRoad]

bonjour cher Maxence


Par formule, tu peux aussi tester

Code :

=NB.JOURS.OUVRES(DATE(0;1;B34+1);DATE(0;1;B34+1)+A35-1)

Ce qui donnerait en VBA (mais beaucoup moins rapide que ta solution .. ;o)

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Testeur_V02()
    Dim i   As Long
    Dim n1  As Integer
    Dim n2  As Integer
    Dim t   As Long
 
    t = Timer()
 
    For i = 1 To 100000
        n1 = Int(Rnd() * 4) + 28
        n2 = Int(Rnd() * 7) + 1
        Debug.Print n1 & vbTab & n2 & vbTab & _
            Application.WorksheetFunction. _
                NetworkDays(DateSerial(1900, 1, n2 + 1), _
                DateSerial(1900, 1, n2 + 1) + n1 - 1)
    Next i
 
    t = Timer() - t
    Debug.Print "Terminé : " & t
End Sub

bonne soirée
michel

[Maxence HUBICHE]

Ouaip !
Je connaissais cette fonction...
Tu fais bien de la mettre en avant.
mais je voulais comprendre la logique de création pour la refaire sans utiliser la bibliothèque Excel (raison pour laquelle j'ai fait ce post sur Général VBA)

ce qui serait supercool, c'est qu'il y ait une solution encore plus courte et plus rapide que la mienne.
Voire, carrément, que ma logique puisse être carrément refondue et améliorée. Ce qui amènerait à un algo complètement différent, et donc à un code complètement différent.

Voilà où se situe ce micro-challenge

Merci pour ta participation, dans tous les cas !

[Tofalu]

Hello,

On eput gagner dans les cas particuliers sur cette ligne :

Code :

bytNbJoursAAjouter = IIf(bytNbJoursTotal Mod 7 = 6, 5, bytNbJoursTotal Mod 7) Mod 6

Là tu fais 2 Mod tout le temps alors qu'on pourrait avoir :

bytNbJoursAAjouter = IIf(bytNbJoursTotal Mod 7 = 6, 5, (bytNbJoursTotal Mod 7) Mod 6)

C'est à dire une seule opération modulo quand NbJoursTotal mod 7 = 6, puisqu'on sait par avance que 5mod6=5.

A part ça, je ne vois pas comment améliorer, si ce n'est eliminer la variable bytNbJoursOuvrables, mais pas vraiment très utile.

Pour une amélioration de l'algo, je ne vois pas comment avoir autre chose

[philben]

bonjour,

une alternative :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Function JoursOuvrables2(ByVal NbJours As Byte, ByVal JourSem As Byte) As Byte
   JoursOuvrables2 = 20 + NbJours Mod 7
   If JoursOuvrables2 + JourSem > 26 Then
      Select Case JoursOuvrables2
      Case 21
         JoursOuvrables2 = JoursOuvrables2 - 1
      Case 22
         JoursOuvrables2 = JoursOuvrables2 + Abs(6 - JourSem) - 2
      Case 23
         JoursOuvrables2 = JoursOuvrables2 + Int(Abs(5.5 - JourSem)) - 2
      End Select
   End If
End Function

les fonctions de test :
* Qualité
---------

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
Sub TestDiffs()
   Const clTests As Long = 100000
   Dim i As Long, lNb As Long
   Dim r1 As Byte, r2 As Byte, n1 As Byte, n2 As Byte
   Randomize
   Debug.Print "Test qualité sur " & FormatNumber(clTests, 0) & " essais..."
   For i = 1 To 100000
      n1 = CByte(Int(Rnd() * 4) + 28)
      n2 = CByte(Int(Rnd() * 7) + 1)
      r1 = JoursOuvrables(n1, n2)
      r2 = JoursOuvrables2(n1, n2)
      If r1 <> r2 Then
         Debug.Print "différence :", n1, n2, r1, r2
         lNb = lNb + 1
      End If
   Next i
   Debug.Print "Nb différences : " & lNb
End Sub

* Performance
--------------

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Sub TestPerf()
   Const clTests As Long = 1000000
   Dim i As Long
   Dim r1 As Byte, r2 As Byte, n1 As Byte, n2 As Byte
   Dim t As Single
   Randomize
   Debug.Print "Test performance sur " & FormatNumber(clTests, 0) & " essais..."
   t = Timer()
   For i = 1 To clTests
      n1 = CByte(Int(Rnd() * 4) + 28)
      n2 = CByte(Int(Rnd() * 7) + 1)
      r1 = JoursOuvrables(n1, n2)
   Next i
   t = Timer() - t
   Debug.Print "Temps algo n°1 : " & t
 
   t = Timer()
   For i = 1 To clTests
      n1 = CByte(Int(Rnd() * 4) + 28)
      n2 = CByte(Int(Rnd() * 7) + 1)
      r1 = JoursOuvrables2(n1, n2)
   Next i
   t = Timer() - t
   Debug.Print "Temps algo n°2 : " & t
End Sub

Philippe

[Maxence HUBICHE]

Bravo Philben !!!!!!






Tu es environ 2.8 fois plus rapide avec cette solution qu'avec la solution N°1 !
Tu es environ 2.6 fois plus rapide avec cette solution qu'avec la solution N° modifiée par Tof !

Chapeau !
Toutes mes félcitations !

un challengeur pour Philben qui, pour le moment remporte la palme ?

[philben]

bonjour Maxence,

merci, mais comme il n'y a que 28 possibilités différentes, je me demande si une <brute force attack> via un select case ne sera pas plus rapide...

je modifie en conséquence le test qualité qui évalue que les 28 solutions :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Sub TestDiffs()
   Dim byNb As Byte, r1 As Byte, r2 As Byte, n1 As Byte, n2 As Byte
   For n1 = 28 To 31
      For n2 = 1 To 7
         r1 = JoursOuvrables(n1, n2)
         r2 = JoursOuvrables2(n1, n2)
         If r1 <> r2 Then
            byNb = byNb + 1
            Debug.Print "Différence n°" & byNb, n1, n2, r1, r2
         End If
      Next n2
   Next n1
   Debug.Print "Nb différences : " & byNb
End Sub

amicalement,

Philippe

[Tofalu]

véto.

La solution de philben si je ne m'abuse tiens compte de mois complets. (mais c'est peut être le but). Moi, je voyais plutot l'intéret d'avoir le nombre de jours ouvrables à partir du début de mois (voire d'une date) pendant une période.

Car si on se borne à des mois complets, comme philben, je pense que le select case peut être plus rapide.

[philben]

bonjour,

Oh le coup bas de Tofalu !

les règles étaient claires, mais voici le libellé exacte pour combler les trous de mémoire...

Cette formule calcul le nombre de jours ouvrables en fonction du nombre de jours du mois ($A35) et du jour de la semaine du jour 1 du mois considéré (B$34)

Un deuxième mini-défi en perspective...

A+

Philippe

[Tofalu]

Oh le coup bas de Tofalu !

Comment ça je suis de mauvaise foi

Cette formule calcul le nombre de jours ouvrables en fonction du nombre de jours du mois ($A35) et du jour de la semaine du jour 1 du mois considéré (B$34)

Dans, ce cas permettez moi maître de faire une objection. Pourquoi tout simplement ne pas passer la date du premier jour du mois en paramètre ? On sait récupérer sa taille et la date du 1, donc "honnetement" je croyais que c'était pour qu'on puisse saisir un NBJours quelconque en fonction du besoin . Sinon, forcément le grând maitre maxence ne se serait servit que de la date comme indiqué plus haut...

Sur ce, je file loin, très loin, en courant ... et sans me retourner

[philben]

Bonjour Monsieur Tofalu,

J'abats définitivement mes cartes :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Function JoursOuvrables3(ByVal NbJours As Byte, ByVal JourSem As Byte) As Byte
   Dim byReste As Byte
   byReste = NbJours Mod 7
   JoursOuvrables3 = (NbJours \ 7) * 5 + byReste
   If byReste Then
      Select Case byReste + JourSem
      Case Is > 8
         JoursOuvrables3 = JoursOuvrables3 - 2 - (JourSem = 7)
      Case Is > 6
         JoursOuvrables3 = JoursOuvrables3 - (byReste + JourSem - 6 + (JourSem = 7))
      End Select
   End If
End Function

Contrôle qualité :
----------------

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Sub TestDiffs()
   Dim byNb As Byte, r1 As Byte, r2 As Byte, n1 As Byte, n2 As Byte
   For n1 = 1 To 240
      For n2 = 1 To 7
         r1 = JoursOuvrables(n1, n2)
         r2 = JoursOuvrables3(n1, n2)
         If r1 <> r2 Then
            byNb = byNb + 1
            Debug.Print "Différence n°" & byNb, n1, n2, r1, r2
         End If
      Next n2
   Next n1
   Debug.Print "Nb différences : " & byNb
End Sub

Contrôle performance :
---------------------

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Sub TestPerf()
   Const clTests As Long = 1000000
   Const cMaxJ As Byte = 240
 
   Dim i As Long
   Dim r As Byte, n1 As Byte, n2 As Byte
   Dim t1 As Single, t2 As Single, tb As Single
   Randomize
   Debug.Print "Test performance sur " & FormatNumber(clTests, 0) & " essais..."
 
   'Blanc
   tb = Timer()
   For i = 1 To clTests
      n1 = CByte(Int(Rnd() * cMaxJ) + 1)
      n2 = CByte(Int(Rnd() * 7) + 1)
   Next i
   tb = Timer() - tb
   Debug.Print "Temps du blanc : " & tb
 
   Randomize
   'Algo 1
   t1 = Timer()
   For i = 1 To clTests
      n1 = CByte(Int(Rnd() * cMaxJ) + 1)
      n2 = CByte(Int(Rnd() * 7) + 1)
      r = JoursOuvrables(n1, n2)
   Next i
   t1 = Timer() - t1 - tb
   Debug.Print "Temps algo n°1 corrigé : " & t1
 
   Randomize
   'Algo 2
   t2 = Timer()
   For i = 1 To clTests
      n1 = CByte(Int(Rnd() * cMaxJ) + 1)
      n2 = CByte(Int(Rnd() * 7) + 1)
      r = JoursOuvrables3(n1, n2)
   Next i
   t2 = Timer() - t2 - tb
   Debug.Print "Temps algo n°2 corrigé : " & t2
 
   Debug.Print "L'algo n°" & IIf(t2 < t1, "2", "1") & " est " & _
               FormatNumber(IIf(t2 < t1, t1 / t2, t2 / t1)) & " plus rapide que l'algo n°" & _
               IIf(t1 < t2, "2", "1")
End Sub

J'ai encore mal...

A+

Philippe