Macro si Date supérieur à + 18H
Bonjour,
J'ai un fichier dans lequel j'effectue le suivi de prêt d'outil à des personnes qui doivent les restituer sous les 18H.
Lorsque la personne emprunte, je flashe son nom et ensuite une macro enregistrer le mouvement dans un onglet historique.
J'aimerais une macro afin que Si la personne n'a pas restitué l'outil avant les 18H (durée de l'emprunt maxi) par rapport à la date en colonne D cela s'enregistrer la ligne complète dans l'onglet "Retard".
Merci par avance de votre aide.
Bonjour,
Voilà une proposition à tester si cela te convient,
Sub retard()
For Each Cel In Range("D3:D" & Range("D" & Rows.Count).End(xlUp).Row)
If Cel.Value <> "" Then
r = Cel.Row
late = Now - Cel.Value
If late > 0.75 Then
Rows(r).EntireRow.Copy
derlig = Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row + 1
MsgBox derlig
Sheets("Retard").Range("A" & derlig).PasteSpecial xlPasteValues
End If
End If
Next Cel
End SubA plus
Bonsoir,
Je te remercie pour ta réponse rapide mais à quel endroit coller ton code car ce n'est pas moi qui est créer le fichier et je ne connais pas grand chose en la matière.
Désolé
Bonjour,
voilà ton fichier, le problème est que ta feuille 1 est protégée je n'ai pas pu faire de changement. La macro s'active à chaque fois que tu rentres des informations.
A plus !
Bonjour
Voici une image du tableau et ci joint le fichier non protéger et le code qui ne fonctionne pas (deuxième partie "retard")
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C3:C50")) Is Nothing Then
Cancel = True
'Récupération des données de la ligne choisie
xDesigna = Cells(Target.Row, "A")
xReferen = Cells(Target.Row, "B")
xNomAjus = Cells(Target.Row, "C")
xDatePre = Cells(Target.Row, "D")
xManquan = Cells(Target.Row, "F")
xStatut = Cells(Target.Row, "E")
'Test si un ajusteur est déja indiqué
If xNomAjus <> Empty Then
xMess = Empty
xMess = xMess & "L'ajusteur " & xNomAjus & " est déjà indiqué" & Chr(13)
xMess = xMess & "Cela veut-il dire qu'il à rendu le matériel" & Chr(13) & Chr(13)
xMess = xMess & " - Si OUI, matériel rendu, donc effacement des données" & Chr(13)
xMess = xMess & " - Si NON, erreur de ligne" & Chr(13)
xRep = MsgBox(xMess, vbQuestion + vbYesNo, "TOTO")
If xRep = vbYes Then
Cells(Target.Row, "C") = Empty
Cells(Target.Row, "D") = Empty
xStatut = "Rendu"
Cells(Target.Row, "E") = ""
GoTo EnregistreHistorique
Else
Exit Sub
End If
Else
xNomAjus = InputBox("Nom de l'ajusteur", "AJUSTEUR")
Cells(Target.Row, "C") = xNomAjus
Cells(Target.Row, "D") = Now
xDatePre = Cells(Target.Row, "D")
xStatut = "Emprunté"
Cells(Target.Row, "E") = xStatut
End If
EnregistreHistorique:
With Sheets("HistoriquePrêt")
xDerLig = .Range("A65536").End(xlUp).Row
xNewlig = xDerLig + 1
.Cells(xNewlig, "A") = xDesigna 'Désignation
.Cells(xNewlig, "B") = xReferen 'Référence
.Cells(xNewlig, "C") = xNomAjus 'Nom ajusteur
.Cells(xNewlig, "D") = Now 'Date pret
.Cells(xNewlig, "F") = xManquan 'Manquant
.Cells(xNewlig, "E") = xStatut 'Statut
End With
End If
End Sub
Sub retard()
For Each Cel In Range("D3:D" & Range("D" & Rows.Count).End(xlUp).Row)
If Cel.Value <> "" Then
r = Cel.Row
late = Now - Cel.Value
If late > CDate("10:00") Then
Rows(r).EntireRow.Copy
derlig = Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row + 1
MsgBox derlig
Sheets("Retard").Range("A2:E" & Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row).ClearContents
End If
End If
Next Cel
End Sub
Bonjour,
il ne fonctionne pas car tu as modifié le code
Changer un 0.75 par un CDate("10:00") n'est pas forcément justifier, sinon j'aurai mis CDate("18:00") comme demandé dès le départ,
Pour obtenir le bon résultat, il te faut faire X heures/24
Ou X représente le nombre d'heures jusqu'au retard.
A plus
Voilà le fichier, avec la macro qui fonctionne !
A plus
Bonjour Braters,
Je te remercie pour ton aide et je devrais pouvoir m'en sortir maintenant.
Merci encore pour le temps accorder à aider les autres.
Bonne semaine.