macro si date supérieur à +18H

xaviermagdelaine

XLDnaute Nouveau
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".
 

Pièces jointes

  • Classeur.xlsm
    535.3 KB · Affichages: 23

Modeste geedee

XLDnaute Barbatruc
Bonsour®
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.
.
pourquoi pas une formule feuille Tampon en E4 :
=SI(D4<>0;SI(D4<(MAINTENANT()-"18:00");"Retard";"Emprunté");"")
puis quelques MEFC...;)
upload_2017-2-11_11-46-48.png
 

Pièces jointes

  • NG58D4F (MX).xlsm
    517.1 KB · Affichages: 17

xaviermagdelaine

XLDnaute Nouveau
Bonjour,
Je souhaite que cela remplisse un autre onglet car le fichier est composé de plusieurs onglet de différents matériels (10 avec plusieurs ligne) et que chaque semaine je dois tous extraire et l'envoyer à d'autres personnes.
Dans mon fichier présent, il s'agit d'un bout du fichier , je n'ai pas voulu mettre la totalité car trop lourd et sans intérêt car indique pour chaque onglet.
Merci de ton aide

Voici le code complet

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

Sans titre.png
 
Dernière édition: