Calcul d'une différence de temps à partir de certaines lignes
Bonjour,
J'aimerais calculer l'âge du lait pour chaque tank (âge du lait = différence de temps entre le remplissage et le soutirage d'un même tank). Seulement les seuls remplissages et soutirages qui m'intéressent sont ceux pour lesquels j'ai une consignation associée. Exemple avec les premières lignes du fichier en pièce jointe :
Le 10/01/2016, consignation du tank 11 contenant la Recette 1 mais remplissage qu'à 14h25 et soutirage de ce même tank le lendemain, le 11/01/2016 à 11h05 --> âge du lait devrait être égal à 20h40. Toutes les lignes de remplissage et soutirage n'ayant pas de consignation sont à retirer puisque cela veut dire que c'est pour la fabrication d'une autre recette non étudiée (autre que Recette 1 et Recette 2). Il se peut également (c'est surtout le cas au début de la base de données, en 2016) que certaines données soient manquantes (qu'on ait par exemple une consignation du tank 8 un soutirage du tank 8 moins d'un jour après la consignation mais pas d'information de remplissage du tank 8), dans ce cas là je n'aurai pas d'âge du lait calculé mais il ne faudrait pas que ça fausse les résultats des jours suivants. On considère que l'âge du lait ne peut pas excéder 24h sinon c'est qu'il y a une erreur.
Je vous remercie d'avance pour votre aide !
Bonjour,
la consignation (si elle est présente) précède-t-elle toujours le remplissage ?
Re Lea,
Voici un essai d'après ce que j'ai compris, sur la base du fichier posté sur ton autre sujet :
Sub test()
With Range("BDD")
t = .Value2
ReDim tnew(1 To UBound(t), 1 To UBound(t, 2) - 2)
For i = UBound(t) To 2 Step -1
If t(i, 1) = "SOUTIRAGE" Then
If Application.CountIfs(.Columns(1).Resize(i - 1), "CONSIGNATION", .Columns(2).Resize(i - 1), "<=" & t(i, 2), _
.Columns(2).Resize(i - 1), ">=" & t(i, 2) - 1, .Columns(4).Resize(i - 1), t(i, 4)) > 0 Then
n = n + 1
For k = 1 To UBound(tnew, 2)
If k = 1 Then tnew(n, k) = t(i, k + 1) + t(i, k + 2) Else tnew(n, k) = t(i, k + 2)
Next k
j = i - 1
Do
If j = 1 then exit do
if t(j, 1) = "REMPLISSAGE" And t(j, 4) = tnew(n, 2) Then
tnew(n, 4) = tnew(n, 1) - (t(j, 2) + t(j, 3))
Exit Do
End If
j = j - 1
Loop
End If
End If
Next i
End With
With Sheets(2)
.Name = "RECAP"
If .ListObjects.Count > 0 Then .ListObjects(1).Delete
If n = 0 Then Exit Sub
.Rows(1).Resize(, 4).Value = Array("DATE", "TANK", "RECETTE", "AGE")
.Cells(2, 1).Resize(n, UBound(tnew, 2)).Value = tnew
.ListObjects.Add(Source:=.UsedRange).Name = "RECAP"
With .ListObjects("RECAP").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("RECAP[DATE]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Apply
End With
.Range("RECAP[DATE]").NumberFormat = "DD/MM/YYYY hh:mm"
'.Range("RECAP[AGE]").NumberFormat = "hh:mm"
End With
End SubJ'ai mis les données de départ sous forme de tableau structuré, lequel est nommé "BDD".
Cdlt,
Oui, elle précède toujours le remplissage
Je vous remercie 3GB, je vais essayer de regarder le code de plus près et reviendrai vers vous
bonjour à tous,
comme j'avais également préparé un code, voici
Sub aargh()
dl = Cells(Rows.CountLarge, 1).End(xlUp).Row
Range("F2").Resize(dl, 1).ClearContents
'tri des données par tank,date et heure
Range("A1").Resize(dl, 5).Sort key1:=Range("D1"), order1:=xlAscending, key2:=Range("B1"), order2:=xlAscending, key3:=Range("C1"), order3:=xlAscending, Header:=xlYes
For i = 2 To dl
type_action = Cells(i, 1)
If Cells(i - 1, 4) = Cells(i, 4) Then
Select Case type_action
Case "CONSIGNATION"
config = 1
debut_consignation = Cells(i, 2) + Cells(i, 3)
Case "REMPLISSAGE"
If config = 1 Then config = 2
debut_remplissage = Cells(i, 2) + Cells(i, 3)
Case "SOUTIRAGE"
If config = 2 Then
fin_soutirage = Cells(i, 2) + Cells(i, 3)
age_du_lait = fin_soutirage - debut_remplissage
Cells(i, 6) = age_du_lait
End If
config = 0
End Select
Else
config = 0
End If
Next i
'pour remettre les données dans l'ordre initial activer l'instruction suivante
'Range("A1").Resize(dl, 6).Sort key1:=Range("B1"), order1:=xlAscending, key2:=Range("C1"), order2:=xlAscending, Header:=xlYes
End SubBonjour, je vous remercie pour votre retour H2SO4. Cependant, certains calculs ne sont pas bons et d'autres sont manquants. Ce qu'a proposé 3GB se rapproche plus de la réalité même s'il y a des erreurs sur les deux dernières lignes du tableau de l'onglet RECAP
Re,
Voici un nouvel essai tenant compte de la nécessité de l'apparition de la CONSIGNATION avant le REMPLISSAGE.
Sub test()
With Range("BDD")
t = .Value2
ReDim tfiltre(1 To UBound(t), 1 To UBound(t, 2) - 2)
For i = UBound(t) To 2 Step -1
If t(i, 1) = "SOUTIRAGE" Then
If Application.CountIfs(.Columns(1).Resize(i - 1), "CONSIGNATION", .Columns(2).Resize(i - 1), "<=" & t(i, 2), _
.Columns(2).Resize(i - 1), ">=" & t(i, 2) - 1, .Columns(4).Resize(i - 1), t(i, 4)) > 0 Then
j = i - 1
Do
If j = 1 Or t(j, 1) = "CONSIGNATION" And t(j, 4) = t(i, 4) Then Exit Do
If t(j, 1) = "REMPLISSAGE" And t(j, 4) = t(i, 4) Then
n = n + 1
tfiltre(n, 1) = t(j, 2) + t(j, 3)
tfiltre(n, 2) = t(i, 4)
tfiltre(n, 3) = t(i, 5)
tfiltre(n, 4) = t(i, 2) + t(i, 3) - tfiltre(n, 1)
Exit Do
End If
j = j - 1
Loop
End If
End If
Next i
End With
Application.ScreenUpdating = False
With Sheets(2)
.Name = "RECAP"
If .ListObjects.Count > 0 Then .ListObjects(1).Delete
If n = 0 Then Exit Sub
.Rows(1).Resize(, 4).Value = Array("DATE", "TANK", "RECETTE", "AGE")
.Cells(2, 1).Resize(n, UBound(tfiltre, 2)).Value = tfiltre
.ListObjects.Add(Source:=.UsedRange).Name = "RECAP"
With .ListObjects("RECAP").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("RECAP[DATE]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Apply
End With
.Range("RECAP[DATE]").NumberFormat = "DD/MM/YYYY hh:mm"
.Range("RECAP[AGE]").NumberFormat = "hh:mm"
End With
Application.ScreenUpdating = True
End SubJ'ai un doute cependant concernant le Tank 8 ! Tout le reste me parait correct.
Cdlt,
Merci beaucoup 3GB ! Tout fonctionne sauf qu'il n'y a pas le calcul de l'âge de lait pour le premier tank 8 (consigné le 02/01/2016, rempli le 02/01/2016 et soutiré le 03/01/2016 à 16h22). Dans l'ancien fichier il était correctement calculé, on trouvant un âge de 17:25 (j'ai volontairement changer le format de cellule pour que ça s'affiche dans le format heure). Aussi, dans l'idéal il faudrait que la date présente dans le RECAP soit la date de remplissage et non celle de soutirage. Par exemple pour la première ligne du tableau se trouvant dans l'onglet RECAP, le tank 10 a commencé à se remplir le 02/01/2016 il serait donc plus judicieux que la date soit celle-ci plutôt que celle du 03/01/2016 correspondant au soutirage.
Oui mais comment faire ? Le problème, c'est que je pars des soutirages et que j'abandonne la recherche dès lors que je trouve une consignation avant un remplissage. Or, avec les 2 premiers TANK 8, c'est ce cas particulier qu'on rencontre. Mais VBA ne peut pas deviner si la CONSIGNATION du même jour est liée au TANK en cours ou au prochain...
Pour le format, je l'avais laissé en commentaire sur mon premier post, je vais le remettre sur mon code (que je vais modifier). Pareil, je vais modifier le code pour prendre la date de remplissage.
et si je vous dis qu'il doit forcément au moins y avoir 8h entre la consignation et le soutirage ? peut être que ça pourrait permettre d'éviter ce problème ?
Je sais pas trop si ça aide, ça fait beaucoup de conditions je trouve, alors qu'il serait plus simple d'inscrire un numéro unique pour identifier les tank... Il faut vraiment appliquer cette pratique.
En tout cas, voici un autre essai avec une fonction récursive :
Sub test()
With Range("BDD")
t = .Value2
ReDim tfiltre(1 To UBound(t), 1 To UBound(t, 2) - 2)
For i = UBound(t) To 3 Step -1
If t(i, 1) = "SOUTIRAGE" Then
temp = Examen(.Cells, t, i)
If IsArray(temp) Then
If temp(1) <> "" Then
n = n + 1
For k = 1 To 4
tfiltre(n, k) = temp(k)
Next k
End If
End If
End If
Next i
End With
Application.ScreenUpdating = False
With Sheets(2)
.Name = "RECAP"
If .ListObjects.Count > 0 Then .ListObjects(1).Delete
If n = 0 Then Exit Sub
.Rows(1).Resize(, 4).Value = Array("DATE", "TANK", "RECETTE", "AGE")
.Cells(2, 1).Resize(n, UBound(tfiltre, 2)).Value = tfiltre
.ListObjects.Add(Source:=.UsedRange).Name = "RECAP"
With .ListObjects("RECAP").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("RECAP[DATE]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Apply
End With
.Range("RECAP[DATE]").NumberFormat = "DD/MM/YYYY hh:mm"
.Range("RECAP[AGE]").NumberFormat = "hh:mm"
End With
Application.ScreenUpdating = True
End Sub
Function Examen(Plage As Range, t, i)
Dim temp(1 To 4)
With Plage
If Application.CountIfs(.Columns(1).Resize(i - 1), "CONSIGNATION", .Columns(2).Resize(i - 1), "<=" & t(i, 2), _
.Columns(2).Resize(i - 1), ">=" & t(i, 2) - 1, .Columns(4).Resize(i - 1), t(i, 4)) > 0 Then
j = i - 1
Do
If j = 1 Then Exit Do
If j > 2 And t(j, 1) = "CONSIGNATION" And t(j, 4) = t(i, 4) Then
vtemp = Examen(.Cells, t, j)
Exit Do
End If
If t(j, 1) = "REMPLISSAGE" And t(j, 4) = t(i, 4) Then
temp(1) = t(j, 2) + t(j, 3)
temp(2) = t(j, 4)
temp(3) = t(j, 5)
temp(4) = t(i, 2) + t(i, 3) - temp(1)
Exit Do
End If
j = j - 1
Loop
If IsArray(vtemp) Then For ii = 1 To 4: temp(ii) = vtemp(ii): Next ii
Examen = temp
End If
End With
End FunctionOn réitère l'opération de recherche, même après avoir trouvé un "CONSIGNATION" s'il existe d'autres "CONSIGNATION" sur la période (le jour courant et la veille).
Avec d'autres cas particuliers, ça pourrait entrainer des doublons... L'avantage, c'est qu'il est plus facile de gérer des doublons que des oublis
Cdlt,
bonsoir,
j'ai également continué de mon coté, j'ai fait une synthèse sur une feuille résultat.
Sub aargh()
'suppression de la feuille de travail si elle existe
Application.DisplayAlerts = False
On Error Resume Next
Sheets("temp").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'ajout d'une feuille de travail
Set wst = Sheets.Add
wst.Name = "temp"
wst.Cells.ClearContents
Set wsb = Sheets("bdd finale")
wsb.UsedRange.Copy wst.Range("A1") 'copie bdd sur feuille de travail
Set wsr = Sheets("resultats") 'feuille résultat
wsr.Cells.ClearContents
wsr.Range("A1").Resize(1, 6) = Split("consignation,remplissage,soutirage,age du lait, recette,tank", ",") 'titre
k = 2 'n° de ligne en cours sur résultat
With wst
dl = .Cells(Rows.CountLarge, 1).End(xlUp).Row
.Range("A1").Resize(dl, 5).Sort key1:=.Range("D1"), order1:=xlAscending, key2:=.Range("B1"), order2:=xlAscending, key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes
i = 2 'n° de ligne sur wst (feuille de travail)
Do
If .Cells(i, 1) = "CONSIGNATION" Then 'on recherche une consignation
trouvé = False 'par défaut on n'a pas trouvé le triplet (consignation, remplissage, soutirage)
'on a trouvé une consignation
debut_consignation = .Cells(i, 2) + .Cells(i, 3)
wsr.Cells(k, 1) = debut_consignation
wsr.Cells(k, 5) = .Cells(i, 5)
wsr.Cells(k, 6) = .Cells(i, 4)
For j = i + 1 To dl 'on recherche un remplissage pour ce tank après la ligne de consignation
If .Cells(j, 1) = "REMPLISSAGE" And .Cells(j, 4) = .Cells(i, 4) Then
'on a trouvé un remplissage
debut_remplissage = .Cells(j, 2) + .Cells(j, 3)
wsr.Cells(k, 2) = debut_remplissage
For q = j + 1 To dl 'on recherche un soutirage pour ce tank après la ligne de remplissage
If .Cells(q, 1) = "SOUTIRAGE" And .Cells(q, 4) = .Cells(i, 4) Then
fin_soutirage = .Cells(q, 2) + .Cells(q, 3)
age_du_lait = fin_soutirage - debut_remplissage
wsr.Cells(k, 3) = fin_soutirage
wsr.Cells(k, 4) = age_du_lait
k = k + 1
.Rows(q).Delete shift:=xlUp 'on supprime les lignes concernées par ce triplet :ligne soutirage
.Rows(j).Delete shift:=xlUp 'on supprime les lignes concernées par ce triplet :ligne remplissage
.Rows(i).Delete shift:=xlUp 'on supprime les lignes concernées par ce triplet :ligne consignation
trouvé = True 'on a trouvé le triplet
Exit For 'on arrête la recherche d'un soutirage pour cette consignation
End If
Next q
End If
If trouvé Then Exit For 'on a trouvé un triplet on arrête la recherche d'un remplissage pour cette consignation
Next j
If Not trouvé Then i = i + 1 'on n'a pas trouvé de remplissage pour cette consignation, on passe à la ligne suivante
Else
i = i + 1 'on n'a pas trouvé de consignation on passe à la ligne suivante
End If
Loop Until .Cells(i, 1) = "" 'tant qu'il y a du texte en colonne 1
'mise en forme résultats
wsr.Cells(2, 4).Resize(dl, 1).NumberFormat = "[h]:mm"
wsr.Columns.AutoFit
wsr.Cells(k, 1).Resize(1, 6).ClearContents
'tri des résultats en fonction de la date et de l'heure
wsr.Range("A1").Resize(k, 6).Sort key1:=wsr.Range("A1"), order1:=xlAscending, Header:=xlYes
End With
Application.DisplayAlerts = False
wst.Delete 'suppression de la feuille de travail
Application.DisplayAlerts = True
End SubÇa fonctionne parfaitement H2SO4 ! Je vous remercie beaucoup ! Serait-il possible que vous commentiez les lignes de code pour que je puisse comprendre votre démarche ? En vous remerciant par avance !
Léa
La solution de 3GB fonctionne quasiment aussi ! merci pour votre aide !
bonsoir,
Ça fonctionne parfaitement H2SO4 ! Je vous remercie beaucoup ! Serait-il possible que vous commentiez les lignes de code pour que je puisse comprendre votre démarche ? En vous remerciant par avance !
Léa
commentaires ajoutés dans le code, voir ci-dessus.
Bonjour,
J'ai supprimé la feuille résultat, insérer un bouton sur l'onglet BDD finale que j'ai affecté à la macro aargh que vous avez créé. Quand j'appuie sur le bouton je ne parviens pas à obtenir l'onglet résultats avec le tableau récapitulatif. J'ai une erreur du type "l'indice est en dehors des dimensions du tableau" pour la ligne "Set wsr = Sheets("resultats")". L'idéal serait d'avoir un bouton sur lequel cliquer à l'ouverture du fichier dans l'onglet BDD finale et que l'onglet résultat se créé ensuite. J'ai également quelques questions concernant le code :
- Je ne comprends pas à quoi servent les lignes de code "On Error Resume Next" et "On Error GoTo 0". Je sais que c'est un moyen de gérer les erreurs mais je ne comprends pas vraiment ce que ça fait exactement.
- Je ne comprends pas à quoi sert la ligne de code "wst.Cells.ClearContents" puisque c'est une nouvelle feuille de travail, elle est forcément dépourvue de formules et de valeurs non ?
- Est ce que "wsb.UsedRange.Copy wst.Range("A1")" revient à faire en deux lignes de code : "wsb.UsedRange.Copy" et "wst.Range("A1").PasteSpecial" ?
Je vous remercie d'avance,
Léa
J'ai oublié une question concernant les lignes de code :
-Vers la fin du code, je ne comprends pas pourquoi on met cette ligne de code "FeuilleAgeLait.Cells(k, 1).Resize(1, 6).ClearContents". Pourquoi vouloir supprimer la dernière ligne ?
bonjour,
J'ai supprimé la feuille résultat, insérer un bouton sur l'onglet BDD finale que j'ai affecté à la macro aargh que vous avez créé. Quand j'appuie sur le bouton je ne parviens pas à obtenir l'onglet résultats avec le tableau récapitulatif. J'ai une erreur du type "l'indice est en dehors des dimensions du tableau" pour la ligne "Set wsr = Sheets("resultats")". L'idéal serait d'avoir un bouton sur lequel cliquer à l'ouverture du fichier dans l'onglet BDD finale et que l'onglet résultat se créé ensuite. J'ai également quelques questions concernant le code :
normal, la feuille résultats doit exister, pour que la macro fonctionne
- Je ne comprends pas à quoi servent les lignes de code "On Error Resume Next" et "On Error GoTo 0". Je sais que c'est un moyen de gérer les erreurs mais je ne comprends pas vraiment ce que ça fait exactement.
ces instructions permettent que la macro ne se plante pas si la feuille temp n'existe pas (on error resume next, signifie si une erreur survient continuer à la ligne suivante, on error goto 0, signifie si une erreur survient arrêter la macro avec son message d'erreur standard)
- Je ne comprends pas à quoi sert la ligne de code "wst.Cells.ClearContents" puisque c'est une nouvelle feuille de travail, elle est forcément dépourvue de formules et de valeurs non ?
ne sert à rien un résidu d'une version précédente du code
- Est ce que "wsb.UsedRange.Copy wst.Range("A1")" revient à faire en deux lignes de code : "wsb.UsedRange.Copy" et "wst.Range("A1").PasteSpecial" ?
presque, il s'agit simplement de faire la copie des cellules d'une feuille à l'autre telles quelles.
-Vers la fin du code, je ne comprends pas pourquoi on met cette ligne de code "FeuilleAgeLait.Cells(k, 1).Resize(1, 6).ClearContents". Pourquoi vouloir supprimer la dernière ligne ?
En fait je commence à remplir la ligne résultat dès que je rencontre le mot "CONSIGNATION", et la ligne est complète quand on a trouvé "REMPLISSAGE" et un "SOUTIRAGE" correspondants, (mais parfois on ne trouve pas), on a donc parfois une ligne incomplète, que j'efface avec cette instruction.
Bonjour,
Je vous remercie pour vos explications. Je viens de me rendre compte d'une spécificité.. Il faudrait rajouter le fait que le laps de temps entre un remplissage et une consignation soit de maximum 10h sinon ça veut dire qu'il manque des lignes et ça va m'engendrer des erreurs de calculs. Il faudrait donc supprimer la consigne qui n'a pas de remplissage à moins de 10h.