calcul délai

[tracor]

salut le phorum

comment peux t' on calculer un nb de jours ouvrés entre 2 dates
en choississant l'intervalle entre ces 2 dates
ex
colonne a : intervalle choisi
du 01/07/04 au 05/07/04
colonne b : date de livraison
copier les deux colonnes
puis effectuer le calcul nbjoursouvrés
et afficher le nombre de jours supérieur à 2

merci pour toutes propositions ou idées

tracor

 

[tracor]

salut au phorum et à michel

j'ai joins un exemple dans l'onglet exemple
en fait la feuille exemple sert à donner les résultats sans passer par un userform pour choisir l'intervalle et afficher le % final

voilà
je réussi à faire tous les pourcentages sauf celui la
merci encore

tracor

 

[michel]

rebonsoir Tracor

j'espere que le fichier modifié répondra à ta demande


bonne soirée
MichelXld

 

[tracor]

oui

tout à fait michel

merci encore pour ta disponibilité

tracor

 

[tracor]

salut le phorum

lorsque je lance la macro elle plante en me mettant un message d'erreur

"dépassement de capacité"

comment puis je palier ce problème

merci d'avance

tracor

 

[michel]

bonsoir Tracor

remplace

Dim Total As Byte ( valeur maxi : 255 )
par
Dim Total As Integer

si Total peut etre supérieur à 32767 utilises : Dim Total As Long


bonne soirée
MichelXld

 

[tracor]

salut michel

je souhaiterai également que le tableau dans lequel la macro va chercher les informations se situe dans une autre feuille
ex sheets("données")
c ce tableau qui est très volumineux
environ 30000 lignes (intégration tous les jours de nouvelles lignes)
la feuille des résultats est en fait une feuille de résultats dans lequel sont regroupés toutes les informations clés
c la seule que je ne parviens pas à établir

merci de ta disponibilité

tracor

 

[tracor]

SALUT LE PHORUM

Je teste ce code et malheureusement cela ne fonctionne pas
il me met "dépassement de capacité"
pourtant j'ai changé le type de variable comme me l'a conseillé michel
et pourtant toujours pareil
voici le codeOption Explicit

Sub test()
'dans cet exemple les samedi ne sont pas comptés en jours ouvrés
Dim Debut As Date, Fin As Date
Dim datefrom As Date, dateto As Date
Dim Compte As Long
Dim total As Long
Dim i As Long
Dim x As Long, NbExp As Long
Dim tableau As Variant

With Sheets("GLOBAL")
datefrom = .Range("f26")
dateto = .Range("f27")
End With

tableau = Sheets("données").Range("a1:cb65000")


For x = 1 To UBound(tableau)
If tableau(x, 48) <= datefrom And tableau(x, 48) >= dateto Then

NbExp = NbExp + 1
Debut = tableau(x, 48) 'date expedition
Fin = tableau(x, 50) 'date livraison

While Debut < Fin Or Compte < 2
Debut = Debut + 1
If TYPEJOUR(Debut) < 1 Then Compte = Compte + 1
Wend
If Compte > 2 Then total = total + 1

End If
Next x
With Sheets("GLOBAL")
.Range("f30") = total
.Range("f31") = NbExp
.Range("f32") = 1 - total / NbExp
End With


End Sub

merci d'avance

tracor

 

[tracor]

Re: calcul délai EUREKA!!!!!

SALUT A TOUT LE MONDE

J'ai trouvé
a force de chercher
un grand merci à michel sans qui rien n'aurait été possible
je met le code qui j'espére servira a quelqu'un
Option Explicit
Option Compare Text

Sub test()
'dans cet exemple les samedi ne sont pas comptés en jours ouvrés
Dim Debut As Date, Fin As Date
Dim datefrom As Date, dateto As Date
Dim Compte As Long
Dim total As Long
Dim x As Long, NbExp As Long
Dim tableau As Variant

With Sheets("global")
datefrom = .Range("f26")
dateto = .Range("f27")
End With

tableau = Sheets("données").Range("a1:cb65000")
For x = 1 To UBound(tableau)
If tableau(x, 48) >= datefrom And tableau(x, 48) <= dateto Then
NbExp = NbExp + 1
Debut = tableau(x, 48) 'date expedition
Fin = tableau(x, 50) 'date livraison

While Debut < Fin Or Compte <= 2
Debut = Debut + 1
If TYPEJOUR(Debut) < 1 Then Compte = Compte + 1
Wend

If Compte > 2 Then total = total + 1
End If
Next
With Sheets("global")

.Range("f30") = total
.Range("f31") = NbExp
.Range("f32") = total / NbExp
End With


End Sub

 

[salim]

Bonsoir le Fil et le Forum

Tracor c'est très gentil à toi de revenir pour dire que ça fonctionne et donner le code alors BRAVO et MERCI parceque il n'y a aucune raison qu'on réprimende les contrevenants et qu'on ne félicite pas les bonnes conduites ce qui est beaucoup plus agréable et je suis sur que tout le monde sera de mon avis.

@+ Salim

 

[tracor]

salut à tous

il est normal que je donne le code car il n'est pas ma propriété à la base mais celle de michel
je n'ai fait qu'adapter le code à mes besoins
encore merci à michel au passage
ainsi qu'a tous les bénévoles qui font avancer ce site qui est excellent pour les excelliens

tracor

 

[tracor]

Re: calcul délai EUREKA BIS

RE A TOUS

CE NOUVEAU MESSAGE POUR METTRE LE BON CODE
UNE REGRETTABLE ERREUR DU A MON EMPRESSEMENT S ETAIT GLISSE DANS UNE DES CONDITIONS
LES CONNAISSEURS APPRECIERONT
TRACOR

OPTION EXPLICIT

Dim Debut As Date, Fin As Date
Dim Compte As Byte, Total As Long
Dim Cell As Range
Dim x As Integer, NbExp As Integer ',

Dim Debut2 As Date, Fin2 As Date
Dim Compte2 As Byte, Total2 As Long
Dim Cell2 As Range
Dim y As Integer, NbExp2 As Integer

Application.StatusBar = "QS livraison CR"
'qs a date
Sheets("données").Select
x = Range("Av35536").End(xlUp).Row
For Each Cell In Range("Av2:Av" & x)
Compte = 0
If CDate(Cell) <= CDate(Sheets("feuil1").Range("N81")) And CDate(Cell) >= CDate(Sheets("feuil1").Range("n80")) Then
NbExp = NbExp + 1
Debut = CDate(Cell) 'date expedition
Fin = CDate(Cell.Offset(0, 2)) 'date livraison
While Debut < Fin Or Compte < 2
Debut = Debut + 1
If TYPEJOUR(Debut) < 1 Then Compte = Compte + 1
Wend
If Compte > 2 Then Total = Total + 1
End If
Next
With Sheets("feuil1").Select
Range("u80") = 1 - Total / NbExp
Range("u83") = Total
Range("u82") = NbExp

End With

'qs J - 2
Sheets("données").Select
y = Range("Av35536").End(xlUp).Row
For Each Cell2 In Range("Av2:Av" & y)
Compte2 = 0
If CDate(Cell2) = CDate(Sheets("feuil1").Range("u88")) Then
NbExp2 = NbExp2 + 1
Debut2 = CDate(Cell2) 'date expedition
Fin2 = CDate(Cell2.Offset(0, 2)) 'date livraison

While Debut2 < Fin2 Or Compte2 < 2
Debut2 = Debut2 + 1
If TYPEJOUR(Debut2) < 1 Then Compte2 = Compte2 + 1
Wend
If Compte2 > 2 Then Total2 = Total2 + 1
End If
Next
With Sheets("feuil1").Select
Range("u85") = 1 - Total2 / NbExp2
Range("u87") = Total2
Range("u86") = NbExp2
End With




End Sub

 

[michel]

bonsoir Salim , bonsoir Tracor

Tracor , merci pour ton message , mais il ne faut pas oublier de remercier Laurent Longre car c'est grace à sa fonction que l'ensemble peut fonctionner :

Function TYPEJOUR(D As Date)
'procedure de Laurent Longre
Dim A As Integer, T As Integer
Dim LP As Date, LD As Long

A = Year(D)
If A > 2099 Then
TYPEJOUR = CVErr(xlErrValue)
Exit Function
End If

LD = Int(D) + 1
If LD <= 2 Then
If LD = 1 Then TYPEJOUR = 2
Exit Function
End If

T = (((255 - 11 * (A Mod 19)) - 21) Mod 30) + 21
LP = DateSerial(A, 3, 2) + T + (T > 48) + 6 - ((A + A \ 4 + T + (T > 48) + 1) Mod 7)
Select Case D
' Jours fériés mobiles
Case Is = LP, Is = LP + 38, Is = LP + 49
TYPEJOUR = 2
' Jours fériés fixes
Case Is = DateSerial(A, 1, 1), Is = DateSerial(A, 5, 1), _
Is = DateSerial(A, 5, 8), Is = DateSerial(A, 7, 14), _
Is = DateSerial(A, 8, 15), Is = DateSerial(A, 11, 1), _
Is = DateSerial(A, 11, 11), Is = DateSerial(A, 12, 25)
TYPEJOUR = 2
Case Else
' Samedi ou dimanche
If Weekday(D, vbMonday) >= 6 Then TYPEJOUR = 1
End Select

End Function


bonne soiree
MichelXld

 

[tracor]

re le phorum
re salim
salut michel

OUPS !!!!

la boulette

désolé

merci également à laurent longre
il est vrai que sa fonction typejour me sert dans un des tous premiers tableaux créé grâce à ce phorum

tracor