Alignement des pointages
Salut,
Je veux un petit programme VBA (Macro) qui m’aligne les pointages d'entrée et sortie par matricule et par date selon un état prédéfini.
vous trouvez ci-joint l'exemple.
Etat prédéfini et pointage mensuelle.
Merci.
Bonjour
Un essai à tester. Te convient-il ?
Bye !
Bonjour,
Merci pour votre attention mais ça ne marche pas, je veux que la liste prédéfini reste comme elle avec les matricules et les noms et prénom et le programme fait aligner les pointage d'entrée et de sortie suivant la date qui existe d'avance dans la liste prédéfini.
Vous trouvez ci-joint un petit exp pour le 1er et le 2 du mois.
le test sur le matricule.
Merci
Re
saberinfo, exécute cette macro dans le fichier "Pointage Mai 2018" pour bien visualiser le problème précédemment évoqué
Option Explicit
Sub test()
Dim r As Range, couleurs, i As Long, j As Long, n As Byte
couleurs = Array(42, 43, 44)
With Sheets(1)
Set r = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To r.Count
j = 1
Do Until r(i) <> r(i).Cells(j)
j = j + 1
Loop
With .Range(r(i), r(i).Cells(j - 1)).Resize(, 4)
If .Range(r(i), r(i).Cells(j - 1)).Cells.Count > 2 Then
If n = 3 Then n = 0
.Interior.ColorIndex = couleurs(n)
n = n + 1
End If
End With
i = i + j - 2
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Sub
Dans ces différents cas, que doit-on retenir comme pointage d'entrée et de sortie pour chaque matricule
La même pour visualiser les matricules à pointage unique
Option Explicit
Sub test2()
Dim r As Range, couleurs, i As Long, j As Long, n As Byte
couleurs = Array(42, 43, 44)
With Sheets(1)
Set r = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To r.Count
j = 1
Do Until r(i) <> r(i).Cells(j)
j = j + 1
Loop
With .Range(r(i), r(i).Cells(j - 1)).Resize(, 4)
If .Range(r(i), r(i).Cells(j - 1)).Cells.Count = 1 Then
If n = 3 Then n = 0
.Interior.ColorIndex = couleurs(n)
n = n + 1
End If
End With
i = i + j - 2
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Sub
klin89
Slt Klin89,
pour les matricules à pointage unique, il faut considérer comme entrée. Et avant il faut un macro qui supprime les pointages répète autant un intervalle moins d'une heure.
Merci beaucoup
Bonjour Klin89,
Les cas des matricules :
- 167 ; 63 ; 129 ; 418 : Pointage d'entrée ou de sortie répétée ( lorsque l'intervalle entre 2 pointages moins de 5 mn c'est une répétition de pointage alors soit on supprime manuellement le 2ème pointage ou avec un macro)
- Pour les autres ce sont de pointage différents soit des autorisations de sortie et d'entrée soit des heures supplémentaires (je dois les vérifier manuellement après l'alignement)
Merci
Re saberinfo,
Si j'ai bien compris
Option Explicit
Sub test()
Dim a, i As Long, j As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
a = Sheets("Pointage Mai 2018").Range("a1").CurrentRegion.Value2
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 3)) Then
Set dico(a(i, 3)) = _
CreateObject("Scripting.Dictionary")
End If
If Not dico(a(i, 3)).exists(a(i, 1)) Then
Set dico(a(i, 3))(a(i, 1)) = _
CreateObject("System.Collections.ArrayList")
End If
If dico(a(i, 3))(a(i, 1)).Count < 2 Then
If dico(a(i, 3))(a(i, 1)).Count = 0 Then
dico(a(i, 3))(a(i, 1)).Add a(i, 4)
Else
If a(i, 4) > dico(a(i, 3))(a(i, 1)).Item(0) + (5 * (1 / 1440)) Then
dico(a(i, 3))(a(i, 1)).Add a(i, 4)
End If
End If
End If
Next
Application.ScreenUpdating = False
With Sheets("Feuil2").Range("a1").CurrentRegion
With .Offset(2, 3).Resize(.Rows.Count - 2, .Columns.Count - 3)
.Clear
.NumberFormat = "hh:mm"
.Font.Size = 8
End With
For j = 4 To .Columns.Count
If dico.exists(.Cells(2, j).Value2) Then
For i = 3 To .Rows.Count Step 2
If dico(.Cells(2, j).Value2).exists(.Cells(i, 1).Value2) Then
If dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).Count = 2 Then
.Cells(i, j).Resize(2).Value = Application.Transpose(dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).ToArray)
Else
.Cells(i, j).Value = dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).Item(0)
End If
End If
Next
End If
Next
.Parent.Activate
End With
Application.ScreenUpdating = True
Set dico = Nothing
End Sub
Pour les tests, j'ai placé la feuille source et la feuille cible dans le même classeur.
klin89
Re ,
On peut remplacer cette boucle :
For j = 4 To .Columns.Count
If dico.exists(.Cells(2, j).Value2) Then
For i = 3 To .Rows.Count Step 2
If dico(.Cells(2, j).Value2).exists(.Cells(i, 1).Value2) Then
If dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).Count = 2 Then
.Cells(i, j).Resize(2).Value = Application.Transpose(dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).ToArray)
Else
.Cells(i, j).Value = dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).Item(0)
End If
End If
Next
End If
Next
par celle ci :
For j = 4 To .Columns.Count
If dico.exists(.Cells(2, j).Value2) Then
For i = 3 To .Rows.Count Step 2
If dico(.Cells(2, j).Value2).exists(.Cells(i, 1).Value2) Then
.Cells(i, j).Resize(dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).Count).Value = _
Application.Transpose(dico(.Cells(2, j).Value2)(.Cells(i, 1).Value2).ToArray)
End If
Next
End If
Next
C'est plus simple
klin89