Option Explicit
' Touche de raccourci du clavier: Ctrl+Shift+P
Public Sub regroupe()
Dim der As Long ' ligne fin Regroupement
Dim lgo As Long ' ligne origine
Dim lgr As Long ' ligne Regroupement
Dim wo As Worksheet ' feuille Base
Dim wr As Worksheet ' feuille Regroupement
Set wo = ThisWorkbook.Sheets("Base")
Set wr = ThisWorkbook.Sheets("Regroupement")
lgr = 2
der = wr.Cells(Rows.Count, 1).End(xlUp).Row
' wr.Cells(2, 1).Resize(der, 6).Select
wr.Cells(2, 1).Resize(der, 6).ClearContents
wr.Cells(2, 1).Resize(1, 6).Value = wo.Cells(2, 1).Resize(1, 6).Value
For lgo = 1 To wo.Cells(Rows.Count, 1).End(xlUp).Row
If wo.Cells(lgo, "A").Value = wr.Cells(lgr, "A").Value _
And wo.Cells(lgo, "C").Value = wr.Cells(lgr, "D").Value + 1 Then
wr.Cells(lgr, "D").Value = wo.Cells(lgo, "D").Value
wr.Cells(lgr, "F").Value = wr.Cells(lgr, "F").Value + wo.Cells(lgo, "F").Value
Else
lgr = lgr + 1
wr.Cells(lgr, 1).Resize(1, 6).Value = wo.Cells(lgo, 1).Resize(1, 6).Value
End If
Next lgo
MsgBox lgr - 1 & " lignes résultat"
wr.Activate
Columns("A:F").AutoFit
End Sub