Recherche de la valeur MAX au format date avec inputBox pour définir une heure en variable

Version imprimable

Bonjour,

je viens de m'inscrire sur ce forum et je sollicite votre aide pour améliorer mon script.
Mon projet est de savoir combien j'ai de personnes dans un bâtiment, on badge en entrant et sortant.
Dans le script ci dessous, je log dans un fichier la valeur max d'entrée dans le bâtiment pour chaque personne.
Ce que j'aimerai c est ajouté une inputBox où la je pourrai choisir l'heure à laquelle je souhaite connaître le nombre de personne dans le bâtiment
au format hh:mm:ss avec masque de saisie pour éviter des anomalies et si la personne entre par exemple

"10:" pour 10h ca ajoute des 0 pour les minutes et secondes.

Aujourd'hui mon script est : (çà fonctionne mais pas d'heure max en variable, la recherche se fait sur toute ma liste....)

Merci d'avance ;)
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 Sub Badge_IN() 'suppression des alertes Application.DisplayAlerts = False Application.ScreenUpdating = False 'declaration des variables Dim test1 As String Dim Der1 As Long Dim der2 As Long Dim Derlig As Long 'Nombre de lignes totales des onglets Badge et Vendredi Der1 = Worksheets("Badge").Range("A2").End(xlDown).Row der2 = Worksheets("vendredi").Range("A2").End(xlDown).Row For i = 2 To Der1 'nettoyage fichier Temporaire Worksheets("TEMP").Range("A1:C5000").ClearContents Worksheets("vendredi").Cells(1, "C").EntireRow.Copy Destination:=Worksheets("TEMP").Range("A1") 'Recherche pour chaque badge test1 = Worksheets("badge").Cells(i, "A").Value For j = 2 To der2 'si le badge est trouver dans la feuille vendredi et la valeur est "IN" alors copie des cellules dans TEMP If Worksheets("vendredi").Cells(j, "C").Value = test1 And Worksheets("vendredi").Cells(j, "B").Value = "IN" Then Worksheets("TEMP").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(j, "A").Value Worksheets("TEMP").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(j, "B").Value Worksheets("TEMP").Range("C" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(j, "C").Value End If Next j Derlig = Worksheets("TEMP").Range("A2").End(xlDown).Row 'Valeur max pour chaque badge dans colonne K Sheets("badge").Range("K" & i).Value = Format(Application.Max(Sheets("TEMP").Range("A2:A" & Derlig)), "hh:mm:ss") Next i 'retour des alertes Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
Je débute en VBA :)

12/10/2018, 13h06
Menhir

A mon avis, ce que tu veux faire n'a pas besoin de VBA.
Je pense qu'il est possible de le faire avec de simples fonctions NB.SI.ENS().
Le plus visuel serait même de faire un graphe indiquant l'évolution sur la journée du nombre de personnes présentes.

Mais pour en dire plus, il faudrait que tu présentes une copie d'écran de tes données pour savoir comment elles sont organisées.
12/10/2018, 14h37
N_OoB

Pas besoin d 'impression d'écran, c'est simple :)

J'ai 3 colonnes:

colonne A: heure de passage du badge au format "dd/mm/yyyy hh:mm:ss"
colonne B: valeurs IN ou OUT
colonne C: ID du badge

Merci d'avance et tu as raison le but dans un second temps est d'avoir un graphique avec vue par mois, semaine, jour du nombre de personnes simultanées dans le bâtiment et le nombre de personnes ayant accéder au moins une fois au bâtiment
12/10/2018, 16h14
Menhir

Citation:

Pas besoin d 'impression d'écran, c'est simple

Si tu le dis :roll:

En supposant qu'au début des relevés le bâtiment était vide.

Deux solutions :

Tu mets en D1 la formule : =NB.SI(B$1:B1;"IN")-NB.SI(B$1:B1;"OUT")Tu copies D1 vers le bas autant que nécessaire.
Ainsi, tu as le nombre de personnes dans le bâtiment à tout instant.
Pour connaitre ce nombre à une date précise, il te suffit d'utiliser une fonction RECHERCHEV() pour trouver la date dans la liste et renvoyer la valeur de la colonne D correspondante. Un conseil : mets le quatrième paramètre de cette fonction à VRAI.

Autre solution :
En supposant que la date choisie est en D1.

Code:

=NB.SI.ENS(A:A;"<"&D1;B:B;"IN")-NB.SI.ENS(A:A;"<"&D1;B:B;"OUT")
18/10/2018, 14h51
N_OoB

1 pièce(s) jointe(s)

J'ai mis une copie de mon fichier avec ma macro car la je ne vois pas comment utiliser la formule dans mon cas
Mais merci pour ton retour Menhir
18/10/2018, 15h09
Menhir

Je n'ouvre pas les fichiers joints.

4 pièce(s) jointe(s)

ok, je t'ai mis des impressions d'écran de mes onglets si tu préfères et la macro ci-dessous: (avec un timer car j'avais des ralentissements sur ma machine)

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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Sub Macro_Presence()
Dim DcalculTps As Double
Dim CalculTps As String
 
  DcalculTps = Timer
''''''''''''''''''''''''''''''''''''''
'Debut TIMER
''''''''''''''''''''''''''''''''''''''
 
'D badge IN
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim test1 As String
Dim Der1 As Long
Dim der2 As Long
Dim Derlig As Long
 
Der1 = Worksheets("Badge").Range("A2").End(xlDown).Row
der2 = Worksheets("vendredi").Range("A2").End(xlDown).Row
 
 
 
For i = 2 To Der1
    'nettoyage fichier temp
    Worksheets("TEMP").Range("A1:C5000").ClearContents
    Worksheets("vendredi").Cells(1, "C").EntireRow.Copy Destination:=Worksheets("TEMP").Range("A1")
    'Recherche pour chaque badge
    test1 = Worksheets("badge").Cells(i, "A").Value
    For j = 2 To der2
        'si le badge est trouver dans la feuille vendredi et la valeur est "IN" je copie la ligne dans TEMP
        If Worksheets("vendredi").Cells(j, "C").Value = test1 And Worksheets("vendredi").Cells(j, "B").Value = "IN" Then
 
            Worksheets("TEMP").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(j, "A").Value
            Worksheets("TEMP").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(j, "B").Value
            Worksheets("TEMP").Range("C" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(j, "C").Value
        End If
    Next j
    Derlig = Worksheets("TEMP").Range("A2").End(xlDown).Row
    'Valeur max pour chaque badge
    Sheets("badge").Range("B" & i).Value = Format(Application.Max(Sheets("TEMP").Range("A2:A" & Derlig)), "hh:mm:ss")
Next i
'F Badge IN
 
'D Badge OUT
Dim test2 As String
Dim Der1o As Long
Dim Der2o As Long
Dim Derligo As Long
 
Der1o = Worksheets("Badge").Range("A1").End(xlDown).Row
Der2o = Worksheets("vendredi").Range("A1").End(xlDown).Row
Derligo = Worksheets("vendredi").Range("A1").End(xlDown).Row
 
 
For Z = 2 To Der1o
    'nettoyage fichier temp
    Worksheets("TEMP").Range("A:AA").ClearContents
    Worksheets("vendredi").Cells(1, "C").EntireRow.Copy Destination:=Worksheets("TEMP").Range("A1")
    'Recherche pour chaque badge
    test2 = Worksheets("badge").Cells(Z, "A").Value
    For y = 2 To Der2o
        'si le badge est trouver dans la feuille vendredi et la valeur est "IN" je copie la ligne dans TEMP
        If Worksheets("vendredi").Cells(y, "C").Value = test2 And Worksheets("vendredi").Cells(y, "B").Value = "OUT" Then
 
            Worksheets("TEMP").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(y, "A").Value
            Worksheets("TEMP").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(y, "B").Value
            Worksheets("TEMP").Range("C" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("vendredi").Cells(y, "C").Value
        End If
    Next y
    'Valeur max pour chaque badge
    Sheets("badge").Range("C" & Z).Value = Format(Application.Max(Sheets("TEMP").Range("A2:A" & Derligo)), "hh:mm:ss")
Next Z
'F Badge OUT
 
'D Presence tour
Der1 = Worksheets("Badge").Range("A1").End(xlDown).Row
For d = 2 To Der1
    If Worksheets("Badge").Range("B" & d).Value - Worksheets("Badge").Range("C" & d).Value > "0" Then
        Worksheets("Badge").Range("D" & d).Value = "IN"
    Else
        Worksheets("Badge").Range("D" & d).Value = "OUT"
    End If
Next d
 
presence = Application.WorksheetFunction.CountIf(Worksheets("Badge").Columns("D"), "IN")
Worksheets("presence").Cells(2, "B").Value = presence
'F Presence Tour
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
 
 
''''''''''''''''''''''''''''''''''''''
'Fin TIMER
''''''''''''''''''''''''''''''''''''''
 
CalculTps = Format((Timer - DcalculTps) / 86400, "hh:mm:ss")
MsgBox "Durée de l'exécution du script " & CalculTps & " minutes", vbInformation
 
End Sub