tri avec format heure minutes

Version imprimable

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:

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:

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:

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.

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:

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

23/04/2011, 17h07
nazaire

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:

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

A plus tard

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:

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

23/04/2011, 18h55
nazaire

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
23/04/2011, 19h06
mercatog

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é
24/04/2011, 11h36
nazaire

Bonjour mercatog,

J'ai parcouru rapidement le tuto, je l'ai télécharger pour le lire à tête reposée.
Je ne suis pas sûr d'avoir bien compris l'histoire de date de début et fin ou je me suis mal exprimé.
Dans mes données qui sont généralement du 01 janv au 31 déc, pour les heures de pointes je dois extraite les données telles que tu l'as fait mais sur les trois mois, janvier, février et décembre.
Je ne vois pas dans le code où est indiqué cette condition sur les mois (1, 2 et 12).

Je suis débutant et essaye de comprendre le fonctionnement du code.

Tb et res ce sont des tableaux de valeurs ?

Code:

Private Function Interv

C'est une fonction que le code utilise, à quoi sert elle ?

Comme je vais devoir dupliquer ce code pour une seconde extraction sur les heures pleines hiver : jan, févr, mars,avr, oct, nov,dec (de 6 h à 22 h sauf les périodes de pointes), j'ai intérêt à bien comprendre le fonctionnement de ton code.

Merci encore
24/04/2011, 11h58
mercatog

Bonjour

Tel que j'ai compris, l'extraction se fait entre 2 dates: Date de début d'extraction DD (exemple en E1: 01/02/2011) et Date de Fin d'extraction DF (exemple en G1: 28/02/2011)

De I1, K1,M1 et O1 tu mets les données des heures de pointe telles que expliquées dans les commentaires du code (exemple: 8:00, 10:30 14:30, 16:00)

Le code permet de copier toutes les lignes correspondant aux critères suivants sur les données de la colonne A:
1. est une date
2. n'est pas un dimanche
3. comprise entre la date de début d'extraction DD et la date de fin d'extraction DF
4. appartient à l'un des 2 intervalles de pointe

Pour la rapidité du traitement, j'ai choisi de travailler avec 2 tableau: Tb dans lequel je mets toutes les données de ta feuille (colonne A et colonne B) et le tableau Res que je construit avec les données répondant aux 4 critères.

Les tableaux offrent un très bon gain du temps de traitement surtout pour les grandes quantités de donnée contrairement au travail direct sur les cellules excel.

A la fin du traitement, je reporte les données du tableau Res dans la feuille pointe.

La fonction Interv permet de savoir si une heure H est comprise entre 2 heures Hd (heure début) et Hf (heure fin)
Interv est une fonction booléenne, elle retourne True si H appartient à l'intervalle [Hd, Hf], sinon False.

Récapitulons:
Inputs:
E1: Date Début d'Extraction
G1: Date Fin d'Extraction
I1: Heure Début Pointe Matin
K1: Heure Fin Pointe Matin
M1: Heure Début Pointe Soir
O1: Heure Fin Pointe Soir

Résultat:
En feuille pointe: les données correspondants aux critères d'extraction.
Voilà.

Bonsoir mercatog,

J'y vois plus clair avec ces explications.
Ce qui veux dire que pour trier sur une année mes données sur trois mois non consécutifs (janv, fév, déc) je dois faire deux extractions, une pour janvier à février et une sur décembre ?

Bonjour,

J'ai voulu modifier la conditions sur les dates pour ne trier que les mois de janvier février et décembre mais ça ne fonctionne pas, la syntaxe n'est pas bonne ?

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
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("données")                                                '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("e2").Value                                         'Heure Début Pointe Matin
    FPm = .Range("e3").Value                                         'Heure Fin Point Matin
    DPs = .Range("e4").Value                                         'Heure Début Point Soir
    FPs = .Range("e5").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) est janvier ou février ou décembre
            If Month(Tb(i, 1) = 1) Or Month(Tb(i, 1) = 2) Or Month(Tb(i, 1) = 12) 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
     Sheets("pointes").Select
     Range("b2").Select
     Range(Selection, Selection.End(xlDown)).Select
     Selection.NumberFormat = Number
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

Merci d'avance