Macro si date supérieure à +18H

Version imprimable

11/02/2017, 11h12
xaviermagdelaine

1 pièce(s) jointe(s)

Macro si date supérieure à +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 enregistre 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 pour votre aide.
11/02/2017, 11h25
unparia

Bonjour
Tu ferais sans doute mieux d'exposer ici techniquement (en nous parlant de cellules) complètement ton problème , accompagné de ton code d'essai.
Lire :
https://www.developpez.net/forums/d8...s-discussions/
Je n'ouvre personnellement jamais un classeur tiers

macro si date supérieur à + 12H

Bonjour, Je vais tenté de vous expliquer plus clairement non besoin sans le fichier.
J'ai fichier "pret" avec 3 onglets.
Chaque onglet
-TamponM2
-HistoriquePrêt
-Retard
est composé de 5 colonnes
-Désignation
-Réf
-Nom
-Date (avec heure)
-Statut( ex.emprunté)
Dans l'onglet TamponM2 plusieurs lignes avec différents outils
ex:
-Ligne 1 tampon M2 4.15
-Ligne 2 tampon M2 4.8
-Ligne 3 tampon M2 5.6
lorsqu'une personne emprunter le tampon M2 5.6, je flasche son non en L3 colonne C ensuite ce mouvement est enregistrer dans l'onglet Historique.
Sur l'onglet TamponM2 cela indique le nom de la personne en L3 colonne C et la date avec heure en D3.
J'aimerais une macro pour remplir automatiquement l'onglet "Retard" si cette personne n'a pas restitué l'outil dans les 18Heures de son prêt par rapport à la date en D3 (onglet TamponM2).
Voici une partie du code qui existe déjà.

La deuxième partie semble ne pas fonctionner (partie "retard"

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
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
 
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
Sheets("Retard").Range("A2:E" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
 
For Each Cel In Range("D3:D" & Range("D" & Rows.Count).End(xlUp).Row)
    If Cel.Value <> "" Then
        r = Cel.Row
        If Cells(r, "E").Value = "Emprunté" Then
        late = Now - Cel.Value
        If late > 0.02 Then
            Rows(r).EntireRow.Copy
            derlig = Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row + 1
            Sheets("Retard").Range("A" & derlig).PasteSpecial xlPasteValues
        End If
        End If
    End If
Next Cel
 
Application.CutCopyMode = False
 
End Sub

Je pense avoir été complet dans mes explication et reste à votre dispo pour explications supplémentaire.
Merci.

11/02/2017, 18h49
Docmarti

Bonjour.

2 modifications:

Code:

Sheets("Retard").Range("A2:E" & Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row).ClearContents

Code:

If late > CDate("18:00") Then
12/02/2017, 09h10
xaviermagdelaine

1 pièce(s) jointe(s)

Macro si date supérieur à +18H

Bonjour,
Je te remercie Docmarti d'avoir pris du temps pour m'aider.
J'ai testé le code après avoir corrigé les deux erreurs et cela me fonctionne pas.
Merci
Pièce jointe 243710
12/02/2017, 11h08
unparia
Bonjour
Je lis ceci dans ton code :

Code:

Cells(Target.Row, "D") = Now

donc ta colonne D contient des Datetime.
puis ceci :
Code:

1 2 late = Now - Cel.Value If late > 0.02 Then
que je compare à cela :

Citation:

si cette personne n'a pas restitué l'outil dans les 18Heures de son prêt par rapport à la date en D3

Heu ... depuis quand une différence de 0.02 entre deux DateTime représente-t-elle 18 heures ? :koi:
J'aurais à ta place au moins eu le réflexe de tester ceci, sur une feuille vierge :

un bouton de commande et :
Code:

1 2 Range("A1").value = Now Range("B1").value = Range("A1").value + 0.02
et aurais regardé A1 et B1 et constaté que 0.02 ne font pas 18 heures. J'en aurais déduit que mon calcul d'écart est erroné, non ?
Intéresse-toi vite à la fonction Datediff, s'il te plait ...
12/02/2017, 11h30
Philippe Tulliez
Bonjour,
En complément de la réponse de Unparia que je salue au passage, je te conseille la lecture des ces deux tutoriels traitant des dates et heures dans excel et VBA
- Comprendre et gérer les dates sous Excel et en VBA
- Utiliser les fonctions Date et Heure sous Excel 2007
12/02/2017, 12h30
xaviermagdelaine

Citation:

Envoyé par unparia

Bonjour
Merci pour vos remarques mais je tiens à rappeler que je suis complément débutant en VBA macro.
Ce n'est pas moi qui est écrit ce code, c'est avec de l'aide.
Effectivement en D3, il s'agit de DateTime.
Je sais que que 0.02 n'est pas égal à 18H , j'ai simplement changer 0.75 en 0.02 pour tester , désolé pour la confusion.
Donc au final, que dois corriger pour que cela fonctionne , avec 18h ou 12h (je fais faire la conversion).
Merci.
12/02/2017, 12h35
Docmarti

Citation:

Envoyé par xaviermagdelaine

J'ai testé le code après avoir corrigé les deux erreurs et cela me fonctionne pas.
Merci

Quel est ton code actuel ?

Bonjour Docmarti,
Mon code actuel est :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
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.04 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 Sub

J'ai mis 0.04 pour tester pour 1 Heure de retard et je corrigerais en 0.75 pour 18H lorsque le code fonctionnerai.
Merci de ton aide

12/02/2017, 13h22
unparia

Quand comptes-tu ouvrir ton aide VBA à la rubrique DateDiff ?
Et quand comptes-tu lire les liens que Philippe Tulliez t'a invité à lire ?

Tu préfères apparemment que quelqu'un t'écrive ton code ? Sans aucun effort de ta part ?
Bonne chance, alors ... (je ne me rappelle pas avoir eu, bien au contraire, un tel comportement, une telle "approche" .... Et ce : depuis mes vraiment tous débuts en développement ...). :cry:
12/02/2017, 14h50
Docmarti

Je voulais dire tout ton code et mets-le entre les balises obtenues en cliquant sur #

Citation:

Envoyé par Docmarti

Je voulais dire tout ton code et mets-le entre les balises obtenues en cliquant sur #

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 
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 > 0.42 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 Sub

Voici la totalité du code.
Désolé mais je ne connais pas grand chose en la matière, j'ai pourtant essayé plusieurs corrections mais à mon niveau je ne vois pas eu cela bloque.
Généralement, en parcourant plusieurs forums , je finis par comprendre et analyser mes fautes mais là à mon niveau de compétence je bloque.
J'ai parcouru les deux liens citer plus haut mais je n'arrive pas le mettre en application.
Je te remercie du temps accorder.

Ton code est bon.

J'ai simplement remis la fonction ClearContents que tu as du supprimer par megarde.

et j'ai ajoute un appel a la procedure Retard - Call retard - car il n'y en avait pas dans ton code.

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
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
       Call retard
    End If
 
 
End Sub
 
Sub retard()
 
Set F = Sheets("Retard")
dern = F.Range("A" & Rows.Count).End(xlUp).Row
If dern > 1 Then
F.Range("A2:E" & F.Range("A" & Rows.Count).End(xlUp).Row).ClearContents
End If
 
Sheets("tamponM2").Activate
 
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.42 Then
 
            Rows(r).EntireRow.Copy
            derlig = Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row + 1
 
            Sheets("Retard").Range("A" & derlig).PasteSpecial xlPasteValues
        End If
    End If
Next Cel
 
End Sub

13/02/2017, 06h25
xaviermagdelaine

Bonjour Docmarti,

Merci d'avoir pris du temps pour m'aider.
Le code semble fonctionner cependant lorsque j'efface le nom du personne (parce la personne a restitué le matériel) , il y a toute une autre ligne qui se met en pointillé 'genre sélection' et le fichier qui tremble un peu.
et je dois cliquer en dehors du tableau pour que cela cesse.
Je te remercie encore mille fois et bonne journée.
13/02/2017, 11h17
Docmarti
Citation:

Envoyé par xaviermagdelaine

Le code semble fonctionner cependant lorsque j'efface le nom du personne (parce la personne a restitué le matériel) , il y a toute une autre ligne qui se met en pointillé 'genre sélection' et le fichier qui tremble un peu.

Tu pourrais utiliser Application.ScreenUpdating = False avant les codes qui modifient ce qui est affiche a l'ecran.

Exemple:
Code:

1 2 3 4 Application.ScreenUpdating = False Rows(r).EntireRow.Copy derlig = Sheets("Retard").Range("A" & Rows.Count).End(xlUp).Row + 1 Sheets("Retard").Range("A" & derlig).PasteSpecial xlPasteValues
13/02/2017, 18h48
xaviermagdelaine

Bonjour Docmarti,
Merci pour aide et tous le temps accordé.
Bonne semaine