Faire un recap du pointage journalier des dates succesives
Bonjour les experts ,
j'ai besoin de votre aide propos d'un pointage journalier que je doit faire un recap chaque fin de mois manuellement , j'ai besoin de le faire automatique avec excel par ce que je traite des centaine de ligne et ça me prit beaucoup de temps , vous trouver si joint un exemple du fichier de pointage ainsi que le recap .
merci a vous.
bonjour,
une proposition via une macro
Sub aargh()
pl = 7 'premiere ligne sur pointage
With Sheets("pointage")
dl = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A" & pl, .Cells(dl, 3)).Sort key1:=.Range("B1"), order1:=xlAscending, key2:=.Range("C1"), order2:=xlAscending, key3:=.Range("A1"), order3:=xlAscending, Header:=xlNo
ke = "": kl = "": l = 5 'premiere ligne sur recap
Set rc = Sheets("recap")
rc.Range("A6:D1000").ClearContents
For i = pl To dl
If .Cells(i, 2) <> ke Or .Cells(i, 3) <> kl Then
If i <> pl Then
l = l + 1
rc.Cells(l, 1) = ke 'engin
rc.Cells(l, 2) = fd ' première date
rc.Cells(l, 3) = ld ' dernière date
rc.Cells(l, 4) = kl 'emplacement
End If
fd = .Cells(i, 1)
ke = .Cells(i, 2)
kl = .Cells(i, 3)
ld = .Cells(i, 1)
Else
ld = .Cells(i, 1)
End If
Next i
End With
End Sub
Bonjour,
Sub Récap()
Dim TR(), r%, n%, i%
With Worksheets("POINTAGE")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A6:C" & n).Sort key1:=.Range("B6"), order1:=xlAscending, key2:=.Range("A6"), _
order2:=xlAscending, Header:=xlYes
ReDim TR(3, 0): TR(0, 0) = .Cells(7, 2)
TR(1, 0) = .Cells(7, 1).Value2: TR(2, 0) = .Cells(7, 1).Value2: TR(3, 0) = .Cells(7, 3)
For i = 8 To n
If .Cells(i, 2) = .Cells(i - 1, 2) And .Cells(i, 3) = .Cells(i - 1, 3) Then
TR(2, r) = .Cells(i, 1).Value2
Else
r = r + 1: ReDim Preserve TR(3, r): TR(0, r) = .Cells(i, 2)
TR(1, r) = .Cells(i, 1).Value2: TR(2, r) = .Cells(i, 1).Value2: TR(3, r) = .Cells(i, 3)
End If
Next i
End With
With Worksheets("RECAP")
.Range("A5").CurrentRegion.Offset(1).Clear
With .Range("A6").Resize(r + 1, 4)
.Value = WorksheetFunction.Transpose(TR)
.HorizontalAlignment = xlCenter
.Columns("B:C").NumberFormat = "dd/mm/yyyy"
With .Borders
.LineStyle = xlContinuous: Weight = xlThin
End With
End With
.Activate
End With
End Sub
Salut h2so4 !
C'est quasi pareil !
vraiment un grand merci a vous
merci infiniment.
Bonsoir,
une correction en integrant le mise en forme proposée par MFERRAND
Sub aargh()
pl = 7 'premiere ligne sur pointage
With Sheets("pointage")
dl = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A" & pl, .Cells(dl, 3)).Sort key1:=.Range("B1"), order1:=xlAscending, key2:=.Range("C1"), order2:=xlAscending, key3:=.Range("A1"), order3:=xlAscending, Header:=xlNo
ke = "": kl = "": l = 5 'premiere ligne sur recap
Set rc = Sheets("recap")
rc.Range("A6:D1000").ClearContents
For i = pl To dl
If .Cells(i, 2) <> ke Or .Cells(i, 3) <> kl Or .Cells(i, 1) - 1 <> ld Then
If i <> pl Then
l = l + 1
rc.Cells(l, 1) = ke 'engin
rc.Cells(l, 2) = fd ' première date
rc.Cells(l, 3) = ld ' dernière date
rc.Cells(l, 4) = kl 'emplacement
End If
fd = .Cells(i, 1)
ke = .Cells(i, 2)
kl = .Cells(i, 3)
ld = .Cells(i, 1)
Else
ld = .Cells(i, 1)
End If
Next i
End With
With Sheets("recap")
With .Range("A6").Resize(l, 4)
.Sort key1:=.Range("A1"), order1:=xlAscending, key2:=.Range("B1"), order2:=xlAscending
.HorizontalAlignment = xlCenter
.Columns("B:C").NumberFormat = "dd/mm/yyyy"
With .Borders
.LineStyle = xlContinuous: Weight = xlThin
End With
End With
.Activate
End With
End Sub
Modification :
If .Cells(i, 2) = .Cells(i - 1, 2) And .Cells(i, 3) = .Cells(i - 1, 3) And _
.Cells(i, 1).Value2 = TR(2, r) + 1 Then
TR(2, r) = .Cells(i, 1).Value2
Else
Vraiment rien a dire