tri avec format heure minutes

**nazaire** · 23/04/2011, 13h37

Bonjour,
Je dois tri et extraire des données (365 jours avec un pas de temps de 10 mn...) selon plusieurs critères.
Un premier tri doit récupérer les données de janvier, février et décembre tous les jours sauf dimanche sur deux périodes de deux heures au choix selon le site.
Les périodes au choix sont 8h-10h et 18-20h ou 9-11 et 18-20h.

J'ai bricolé une macro qui me permet de réaliser ce tri et extraction.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub pointes() 'ok
Dim i As Long
Dim a, b, c, d As Long
 
 
    a = Application.InputBox("Sélectionnez l'heure de début de pointe du matin  :", Type:=1)
    b = Application.InputBox("Sélectionnez l'heure de fin de pointe du matin  :", Type:=1)
    c = Application.InputBox("Sélectionnez l'heure de début de pointe du soir  :", Type:=1)
    d = Application.InputBox("Sélectionnez l'heure de fin de pointe du soir  :", Type:=1)
 
i = 2
j = 2
 
 While Not IsEmpty(Cells(i, 1))
 
        If Month(Cells(i, 1)) = 1 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) >= a And Hour(Cells(i, 1)) < b _
            Or Month(Cells(i, 1)) = 1 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) >= c And Hour(Cells(i, 1)) < d _
            Or Month(Cells(i, 1)) = 2 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) >= a And Hour(Cells(i, 1)) < b _
            Or Month(Cells(i, 1)) = 2 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) >= c And Hour(Cells(i, 1)) < d _
            Or Month(Cells(i, 1)) = 12 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) >= a And Hour(Cells(i, 1)) < b _
            Or Month(Cells(i, 1)) = 12 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) >= c And Hour(Cells(i, 1)) < d _
        Then
        Range(Cells(i, 1), Cells(i, 2)).Select
        Selection.Copy Range(Cells(j, 4), Cells(j, 5))
        i = i + 1
        j = j + 1
         Else
        i = i + 1
 
        End If
 
  Wend
    Range("D2:E2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Sheets("pointes").Select
    Range("A2:B2").Select
    ActiveSheet.Paste
 
 
End Sub

mais sur plusieurs sites nouveaux, la période du matin n'est pas sur des heures rondes. Et là ça coince, ma macro ne permet pas de trier entre 8:30 et 10:30 par exemple.

J'ai testé une parade avec la concaténation heure: minutes
voici l'idée :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub concatener()
Dim a, b, c, d As Long
 
 
  a = Application.InputBox("Sélectionnez l'heure de début de pointe du matin  :", Type:=2)
  b = Application.InputBox("Sélectionnez l'heure de fin de pointe du matin  :", Type:=2)
 
 
If Hour(Cells(i, 1)) & ":" & Minute(Cells(i, 1)) >= a And Hour(Cells(i, 1)) & ":" & Minute(Cells(i, 1)) < b _
Then
 Cells(51, 3).Select
        Selection = "bonjour"
 
         Else
        Selection = "a demain"
 
        End If
 
 
End Sub

Pour que ça fonctionne j'ai modifier le type de l'inputbox en type 2

Par contre quand j'insère la condition avec cette concaténation dans ma macro initiale ça ne marche pas. Il doit y avoir un conflit de type pour a et b et de déclaration de ces variables.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub pointesdemiheure()
Dim i As Long
Dim a, b, c, d As Long
 
 
    a = Application.InputBox("Sélectionnez l'heure de début de pointe du matin  :", Type:=2)
    b = Application.InputBox("Sélectionnez l'heure de fin de pointe du matin  :", Type:=2)
    'c = Application.InputBox("Sélectionnez l'heure de début de pointe du soir  :", Type:=2)
    'd = Application.InputBox("Sélectionnez l'heure de fin de pointe du soir  :", Type:=2)
 
i = 2
j = 2
 
 While Not IsEmpty(Cells(i, 1))
 
        If Month(Cells(i, 1)) = 1 And Weekday(Cells(i, 1)) <> 1 And Hour(Cells(i, 1)) & ":" & Minute(Cells(i, 1)) >= a And Hour(Cells(i, 1)) & ":" & Minute(Cells(i, 1)) < b _
        Then
        Range(Cells(i, 1), Cells(i, 2)).Select
        Selection.Copy Range(Cells(j, 4), Cells(j, 5))
        i = i + 1
        j = j + 1
         Else
        i = i + 1
 
        End If
 
  Wend
    Range("D2:E2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Sheets("pointes").Select
    Range("A2:B2").Select
    ActiveSheet.Paste
 
 
End Sub

Je me permets de joindre mon fichier pour que ce soit plus explicite.
Je travaille d'abord sur la macro heure pointe, si ça marche je dupliquerai l'astuce sur la macro heure pleine hiver.

Merci d'avance pour le coup de pouce.

**mercatog** · 23/04/2011, 16h04

Bonjour
en utilisant des cellules de la feuille pour entrer les heures de points et date de début et de fin de la zone d'extraction, une proposition

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CommandButton1_Click()
Dim LastLig As Long, i As Long, k As Long
Dim DD As Date, DF As Date, DPm As Date, FPm As Date, DPs As Date, FPs As Date
Dim Tb, Res()
 
With Sheets("Feuil5")                                                'A adapter au nom de ta feuille
    DD = CDate(.Range("E1").Value)                                   'Date de début
    DF = CDate(.Range("G1").Value)                                   'Date fin
    DPm = .Range("I1").Value                                         'Heure Début Pointe Matin
    FPm = .Range("K1").Value                                         'Heure Fin Point Matin
    DPs = .Range("M1").Value                                         'Heure Début Point Soir
    FPs = .Range("O1").Value                                         'Heure Fin Point Soir
 
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Tb = .Range("A2:B" & LastLig).Value                              'A adapter aux colonnes de données, ici A:B
    ReDim Res(1 To 2, 1 To 1)
    Res(1, 1) = .Cells(1, 1)
    Res(2, 1) = .Cells(1, 2)
    k = 1
    For i = 1 To UBound(Tb)
        If Month(Tb(i, 1)) = 1 And Weekday(Tb(i, 1), vbMonday) < 7 Then
            If Interv(Tb(i, 1), DPm, FPm) Or Interv(Tb(i, 1), DPs, FPs) Then
                k = k + 1
                ReDim Preserve Res(1 To UBound(Tb, 2), 1 To k)
                Res(1, k) = Tb(i, 1)
                Res(2, k) = Tb(i, 2)
            End If
        End If
    Next i
End With
With Sheets("pointes")
    .UsedRange.Clear
    .Range("A1").Resize(UBound(Res, 2), 2).Value = Application.Transpose(Res)
End With
End Sub
 
Private Function Interv(ByVal H As Date, Hd As Date, Hf As Date) As Boolean
Dim Hr As Date
 
Hr = TimeSerial(Hour(H), Minute(H), 0)
Interv = DateDiff("n", Hd, Hr) >= 0 And DateDiff("n", Hf, Hr) <= 0
End Function

**nazaire** · 23/04/2011, 18h07

Bonjour mercatog et merci d'avoir pris le temps de répondre à mon message.

Si je comprends bien il faut saisir en E1 et G1 des dates de début et fin, mais de quoi ? De la liste de données ? Du 01/01/2010 00:00 au 31/12/201 23:50 si les données sont sur l'année entière ?.

Je vais tester ce code qui pour moi est fort complexe et reviendrai vous poser des questions pour tenter de le comprendre afin de l'adapter puisqu'il ne prend en compte que le mois de janvier si je comprends bien.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Month(Tb(i, 1)) = 1

A plus tard

**mercatog** · 23/04/2011, 18h27

Désolé, En effet, j'avais commencé à faire plus générale (Date de début et date de fin d'extraction par exemple DD=05/01/2011 et DF: 13/03/2011)

Le code permet d'extraire toutes les données entre ces 2 dates et répondant aux critères (heures de pointe et dimanche).
J'ai restructuré les tests IF pour une question de clarté.

Ci-joint code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub CommandButton1_Click()
Dim LastLig As Long, i As Long, k As Long
Dim DD As Date, DF As Date, DPm As Date, FPm As Date, DPs As Date, FPs As Date
Dim Tb, Res()
 
With Sheets("Feuil5")                                                'A adapter au nom de ta feuille
    DD = CDate(.Range("E1").Value)                                   'Date de début
    DF = CDate(.Range("G1").Value)                                   'Date fin
    DPm = .Range("I1").Value                                         'Heure Début Pointe Matin
    FPm = .Range("K1").Value                                         'Heure Fin Point Matin
    DPs = .Range("M1").Value                                         'Heure Début Point Soir
    FPs = .Range("O1").Value                                         'Heure Fin Point Soir
 
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Tb = .Range("A2:B" & LastLig).Value                              'A adapter aux colonnes de données, ici A:B
    ReDim Res(1 To 2, 1 To 1)
    'On remplit la ligne des titres
    Res(1, 1) = .Cells(1, 1): Res(2, 1) = .Cells(1, 2): k = 1
    For i = 1 To UBound(Tb)
        'Si Tb(i,1) est une date
        If IsDate(Tb(i, 1)) Then
            'Si la date Tb(i,1) est comprise en Date début et Date Fin
            If DateDiff("d", DD, Tb(i, 1)) >= 0 And DateDiff("d", DF, Tb(i, 1)) <= 0 Then
                'Si la date Tb(i,1) n'est pas un dimanche
                If Weekday(Tb(i, 1), vbMonday) < 7 Then
                    'Si lheure est comprise dans les intervales de pointes
                    If Interv(Tb(i, 1), DPm, FPm) Or Interv(Tb(i, 1), DPs, FPs) Then
                        'On remplit le tableau Res
                        k = k + 1
                        ReDim Preserve Res(1 To UBound(Tb, 2), 1 To k)
                        Res(1, k) = CDbl(Tb(i, 1))
                        Res(2, k) = Tb(i, 2)
                    End If
                End If
            End If
        End If
    Next i
End With
With Sheets("pointes")
    .UsedRange.Clear
    With .Range("A1").Resize(UBound(Res, 2), 2)
        .Value = Application.Transpose(Res)
        .NumberFormat = "dd/mm/yyyy hh:mm"
    End With
End With
End Sub
 
Private Function Interv(ByVal H As Date, Hd As Date, Hf As Date) As Boolean
Dim Hr As Date
 
Hr = TimeSerial(Hour(H), Minute(H), 0)
Interv = DateDiff("n", Hd, Hr) >= 0 And DateDiff("n", Hf, Hr) <= 0
End Function

**nazaire** · 23/04/2011, 19h55

Le premier code fonctionne très bien, par contre, les dates entre le 01/01 et le 12/01 s'affichent en mm/jj/aaaa et jj/mm/aaaa ensuite ??

Ya t'il une explication ?

Je récupère le second code pour voir les modif et les explications qui vont avec.

Cordialement

**mercatog** · 23/04/2011, 20h06

L'explication, grosso modo c'est que Excel interprète les dates différemment de vba (date au format anglophone mm/dd/yyyy.
Pour pallier à ça, en mets directement la valeur en double de la date et après rapatriement des données, changer le format des cellules.
Regarde ce tutoriel bien expliqué et illustré

tri avec format heure minutes

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager