[XL-2003] Mise en forme d'une page en VBA [Résolu]

[Naru80]

Bonjour,

Je souhaite mettre en page une page Excel à l'aide d'une macro

Je vous ai mis un fichier avec une feuille ou vous avez l'extract Brut et une seconde feuille avec la mise en forme que je souhaiterai.

Mon soucis est que pour un agent il peut avoir plein de connexion et déconnexion il faut donc les supprimer si elle sont inférieur à 20 min.

Cela me permettrai de pouvoir avoir une heure d'entrée, une heure de coupure repas, une heure de reprise et une heure de fin.

J'ai déjà demandé de l'aide sur ce forum et Mercatog m'avait répondu avec rapidité et une très grande efficacité j'utilise d’ailleurs son bout de code et je l'en remercie encore.

Merci a vous par avance.

[Naru80]

Après avoir lu la charte des pièces jointe oui ok j'aurai du le lire avant mais quand on est dans du code jusqu'au coup on ne pense pas a lire mais on essaye de sortir de la en trouvant la solution la plus simple et la pour moi c’était de mettre un fichier en pièce jointe.

Donc je vais essayer d'expliquer avec des mots ma demande.

Je fais une extract d'un outils qui me donne les log et delog des personnes.
dans une meme journée une personne peut se loguer et delouer plein de fois mais j'ai besoin de garder que 4 valeurs :
- 1 entree
- 1 heure de coupure repas
- 1 heure de reprise
- 1 heure de fin

Donc pour cela il faut je pense supprimer tous les codes ou on a moins de 20min entre 2 log/delog

J'aimerai afficher en :
- A1 le nom de l'agent
- B1 l'heure d’entrée
- C1 l'heure de coupure repas
- D1 l'heure de reprise
- E1 l'heure de fin
- F1 ID de l'agent

Mon extract de base me donne le nom de l'agent dans la colonne A, tous les log de connexion dans la colonnes D et tous les delog de la journée dans la colonnes F et pour finir tous les ID des agents dans la colonne AO

Je ne sais pas par ou commencer a vrai dire

J’espère avoir était clair sinon demandé moi.

[jfontaine]

Bonjour,

Voici une procédure qui devrait faire ce que tu souhaites

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
Sub Miseenpage()
 
Dim iSource As Long
Dim shSource As Worksheet
 
Dim shCible As Worksheet
Dim iCible As Long
Dim rgCible As Range
 
Set shSource = Worksheets("Fichier d'origine")
Set shCible = Worksheets("Fichier que j'aimerai")
 
 
For iSource = 4 To shSource.Range("A" & shSource.Rows.Count).End(xlUp).Row
 
    'Recherche 'agent sur la feuille cible
    Set rgCible = shCible.Range("A:A").Find(what:=shSource.Range("A" & iSource).Value, lookat:=xlWhole)
 
    If rgCible Is Nothing Then
        'Ajout de l'agent
        iCible = shCible.Range("A" & shCible.Rows.Count).End(xlUp).Row + 1
        shCible.Range("A" & iCible).Value = shSource.Range("A" & iSource).Value
    Else
        iCible = rgCible.Row
    End If
 
    'Ajoute les heures
    If shCible.Range("B" & iCible).Value = "" Then
        shCible.Range("B" & iCible).Value = shSource.Range("D" & iSource).Value
        shCible.Range("C" & iCible).Value = shSource.Range("F" & iSource).Value
        GoTo suite
    End If
 
    If DateDiff("n", TimeValue(shCible.Range("C" & iCible).Text), TimeValue(shSource.Range("D" & iSource).Text)) < 20 Then
        shCible.Range("C" & iCible).Value = shSource.Range("F" & iSource).Value
        GoTo suite
    End If
 
     If shCible.Range("D" & iCible).Value = "" Then
        shCible.Range("D" & iCible).Value = shSource.Range("D" & iSource).Value
        shCible.Range("E" & iCible).Value = shSource.Range("F" & iSource).Value
        GoTo suite
    End If
 
    If DateDiff("n", TimeValue(shCible.Range("E" & iCible).Text), TimeValue(shSource.Range("D" & iSource).Text)) < 20 Then
        shCible.Range("E" & iCible).Value = shSource.Range("F" & iSource).Value
        GoTo suite
    End If
 
suite:
    shCible.Range("F" & iCible).Value = shSource.Range("AO" & iSource).Value
 
 
 
Next iSource
 
End Sub

[Naru80]

Merci pour ta réponse

Quand j’exécute le code il me donne un code erreur 13 avec une incompatibilité de type

quand je fais debogage il bloque sur la ligne

Code :

1
2
 
If DateDiff("n", TimeValue(shCible.Range("C" & iCible).Text), TimeValue(shSource.Range("D" & iSource).Text)) < 20 Then

dans la feuille "Fichier que j'aimerai" il me donne quelque valeur

[Naru80]

en faite cela fonctionne très bien.

Il fallait que je mette mes cellule en format heure

Un grand merci pour la réponse jfontaine

[jfontaine]

Cela provient du format des cellules

Ajoutes cette ligne juste avant le commentaire "Ajoutes les heures"

Code :

1
2
3
shCible.Range("B" & iCible & ":E" & iCible).NumberFormatLocal = "h:mm;@"
 
'Ajoute les heures

[Naru80]

nickel merci sa fonctionne très bien.

Si je peux abuser en testant sur plusieurs jours j'ai trouvé 1 erreur avec le code.

Un agent a eu un log et delog sur la même heure en début de poste donc au lieu d'avoir ses heures normal j'ai :

14:00:00	14:00:00	15:15:00	18:31:00

alors que j'aurai du avoir

14:00:00	18:31:00	19:01:00    21:45:00

on peut mettre une condition pour éviter cela ?

[jfontaine]

Si on n'intègre pas la ligne qui à une heure de connexion = heure de déconnexion.
Cela corrige t'il le problème

Code :

If shSource.Range("D" & iSource).Value <> shSource.Range("F" & iSource).Value Then

soit tout le 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
 
Dim iSource As Long
Dim shSource As Worksheet
 
Dim shCible As Worksheet
Dim iCible As Long
Dim rgCible As Range
 
Set shSource = Worksheets("Fichier d'origine")
Set shCible = Worksheets("Fichier que j'aimerai")
 
 
For iSource = 4 To Range("A" & shSource.Rows.Count).End(xlUp).Row
 
    If shSource.Range("D" & iSource).Value <> shSource.Range("F" & iSource).Value Then
 
        'Recherche 'agent sur la feuille cible
        Set rgCible = shCible.Range("A:A").Find(what:=shSource.Range("A" & iSource).Value, lookat:=xlWhole)
 
        If rgCible Is Nothing Then
            'Ajout de l'agent
            iCible = shCible.Range("A" & shCible.Rows.Count).End(xlUp).Row + 1
            shCible.Range("A" & iCible).Value = shSource.Range("A" & iSource).Value
        Else
            iCible = rgCible.Row
        End If
 
        shCible.Range("B" & iCible & ":E" & iCible).NumberFormatLocal = "h:mm;@"
 
        'Ajoute les heures
        If shCible.Range("B" & iCible).Value = "" Then
            shCible.Range("B" & iCible).Value = shSource.Range("D" & iSource).Value
            shCible.Range("C" & iCible).Value = shSource.Range("F" & iSource).Value
            GoTo suite
        End If
 
        If DateDiff("n", TimeValue(shCible.Range("C" & iCible).Text), TimeValue(shSource.Range("D" & iSource).Text)) < 20 Then
            shCible.Range("C" & iCible).Value = shSource.Range("F" & iSource).Value
            GoTo suite
        End If
 
         If shCible.Range("D" & iCible).Value = "" Then
            shCible.Range("D" & iCible).Value = shSource.Range("D" & iSource).Value
            shCible.Range("E" & iCible).Value = shSource.Range("F" & iSource).Value
            GoTo suite
        End If
 
        If DateDiff("n", TimeValue(shCible.Range("E" & iCible).Text), TimeValue(shSource.Range("D" & iSource).Text)) < 20 Then
            shCible.Range("E" & iCible).Value = shSource.Range("F" & iSource).Value
            GoTo suite
        End If
 
suite:
        shCible.Range("F" & iCible).Value = shSource.Range("AO" & iSource).Value
 
    End If
 
Next iSource

[mercatog]

Bonjour
Une autre proposition (à tester en adaptant les noms des feuilles Source et Destination)

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
Sub Transfert()
Dim LastLig As Long, i As Long, j As Long
Dim idAgent As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
'-Transfert et réorgnaisation des données dans la variable Tb à partir de la feuille Source 'adapter le nom de la feuille
With Worksheets("Source")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Tb = .Range("A4:AO" & LastLig)
    For i = UBound(Tb, 1) To 2 Step -1
        If Tb(i - 1, 41) <> idAgent Then
            idAgent = Tb(i - 1, 41)
        Else
            If Abs(Tb(i - 1, 6) - Tb(i, 4)) < 1 / 72 Then    '1/72=20minutes/24heures
                Tb(i - 1, 6) = Tb(i, 6)
                Tb(i, 1) = ""
            End If
        End If
    Next i
End With
 
'-Remplissage de la variable Res à partir de Tb
idAgent = ""
For i = 1 To UBound(Tb, 1)
    If Tb(i, 1) <> "" And Abs(Tb(i, 6) - Tb(i, 4)) >= 1 / 72 Then
        If Tb(i, 41) <> idAgent Then
            idAgent = Tb(i, 41)
            j = j + 1
            ReDim Preserve Res(1 To 6, 1 To j)
            Res(1, j) = Tb(i, 1)
            Res(2, j) = Tb(i, 4)
            Res(3, j) = Tb(i, 6)
            Res(6, j) = idAgent
        Else
            Res(4, j) = Tb(i, 4)
            Res(5, j) = Tb(i, 6)
        End If
    End If
Next i
'Transfert du resultat final à partir de la variable Res vers la feuille Destination 'adapter le nom de la feuille
If j > 1 Then Worksheets("Destination").Range("A2").Resize(j, 6) = Application.Transpose(Res)
End Sub

[Naru80]

Pour jfontaine :

Je viens de tester et non sa ne fonctionne pas sa me donne en résultat

 15:15	18:31 	19:01 	21:45

Pour mercatog
Même chose je viens de tester et j'ai la même erreur

 15:15	18:31 	19:01 	21:45

au lieu de

 14:00	18:31 	19:01 	21:45

En revanche la méthode de mercatog est beaucoup plus rapide

Dans vos 2 méthodes vous avez supprimez si il y avait une même heure pour le log et delog effectivement quand il y a 10 déconnexion dans la journée la méthode est excellente mais pas pour la première connexion de la journée. On doit absolument garder le premier log

Merci a vous 2 pour le temps

[mercatog]

Mets en PJ un fichier pour pouvoir re tester

[Naru80]

Voici le fichier en pièce jointe j'ai remplacé les noms des agents par des chiffres
l'erreur est pour le n°34

avec le bon fichier c'est mieux

[mercatog]

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
Sub Transfert()
Dim LastLig As Long, i As Long, j As Long
Dim idAgent As String
Dim P As Double
Dim Tb, Res()
 
Application.ScreenUpdating = False
P = 1 / 72                                                           '1/72=20minutes/24heures
 
'-Transfert et réorgnaisation des données dans la variable Tb à partir de la feuille Source 'adapter le nom de la feuille
With Worksheets("Source")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Tb = .Range("A4:AO" & LastLig)
    For i = UBound(Tb, 1) To 2 Step -1
        If Tb(i - 1, 41) <> idAgent Then
            idAgent = Tb(i - 1, 41)
        Else
            If Tb(i - 1, 6) < Tb(i - 1, 4) + P Or Tb(i - 1, 6) > Tb(i, 4) - P Then
                Tb(i - 1, 6) = Tb(i, 6)
                Tb(i, 1) = ""
            End If
        End If
    Next i
End With
 
'-Remplissage de la variable Res à partir de Tb
idAgent = ""
For i = 1 To UBound(Tb, 1)
    If Tb(i, 1) <> "" Then
        If Tb(i, 41) <> idAgent Then
            j = j + 1
            ReDim Preserve Res(1 To 6, 1 To j)
            Res(1, j) = Tb(i, 1)
            Res(2, j) = Tb(i, 4)
            Res(3, j) = Tb(i, 6)
            idAgent = Tb(i, 41)
            Res(6, j) = idAgent
        Else
            Res(4, j) = Tb(i, 4)
            Res(5, j) = Tb(i, 6)
        End If
    End If
Next i
 
'Transfert du resultat final à partir de la variable Res vers la feuille Destination 'adapter le nom de la feuille
If j > 1 Then Worksheets("Destination").Range("A2").Resize(j, 6) = Application.Transpose(Res)
End Sub

[Naru80]

Une fois de plus il ne me reste qu'une chose à dire :
MERCI

La derniere version fonctionne tres bien.