Alignement des pointages

Question

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...

gmb · Answer

Un essai à tester. Te convient-il ? Bye ...

gmb · Answer

Nouvel essai. Bye ...

Klin89 · Answer

Pour les matricules suivants, quels sont les pointages d'entrée et de sortie (colonne Time) à reporter klin89...

Klin89 · Answer

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

Klin89 · Answer

Re saberinfo,

Dans l'image ci-dessous, j'ai relevé différents cas pouvant se présenter

Peux-tu nous dire quels sont pour chaque matricule et date associée, le pointage d'entrée et de sortie à retenir et fournir une explication claire et précise

klin89

Klin89 · Answer

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.

9etat-predifini.zip (158.43 Ko)

klin89

Klin89 · Answer

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...