Crikey, that is slow. This is much faster

[VBA]Sub SyntheseActivite()
Dim onecell As Range, ar As Range
Dim arl As Long
Dim vv As String, cini As String, sem As String, a1 As String, cfin As String
Dim ri, RowT, EndR As Integer, mlt As Integer
Dim rFormula As Variant

Application.ScreenUpdating = False

Worksheets("Synthese Activite").Cells.Clear

With Worksheets("DATA")

sem = Application.InputBox(prompt:="Input week number", Title:="Week number")
If sem = "False" Then Exit Sub
arl = WorksheetFunction.Match("S" & sem, .Range("I29:GJ29"), 0) + 8
ri = 1
mlt = 1
p = 49

For Each onecell In .Range(.Cells(32, arl), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, arl))

If WorksheetFunction.Sum(onecell.Resize(1, 5)) > 0 Then

.Range(.Cells(onecell.Row, "A"), .Cells(onecell.Row, "G")).Copy _
Destination:=Worksheets("Synthese Activite").Range("A" & ri)
Sheets("Synthese Activite").Range("J" & ri).FormulaR1C1 = _
"=SUM(DATA!R[" & onecell.Row - ri & "]C[" & arl - 10 & "]:R[" & onecell.Row - ri & "]C[" & arl - 6 & "])"

ri = ri + 1
End If
Next
End With

With Worksheets("Synthese Activite")

For Each onecell In .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)

cfin = .Cells(onecell.Row, "E").Value
a1 = "$B$1:$B" & onecell.Row & ",$B" & onecell.Row & _
",$E$1:$E" & onecell.Row & ",$E" & onecell.Row
If Application.CountIfs(.Range("B5:B" & onecell.Row), .Range("B" & onecell.Row), _
.Range("E5:E" & onecell.Row), .Range("E" & onecell.Row)) > 1 Then

vv = .Cells(onecell.Row, "E").Value
RowT = WorksheetFunction.Match(vv, .Range("E1:E" & onecell.Row), 0)
.Cells(RowT, "G").Value = .Cells(RowT, "G").Value & ", " & .Cells(onecell.Row, "G").Value
.Cells(RowT, 10).Value = "=" & .Cells(RowT, 10).Value & "+" & .Cells(onecell.Row, 10).Value
.Rows(onecell.Row).EntireRow.Delete
mlt = mlt + 1
End If
Next

.Cells.Validation.Delete
.Cells.ClearFormats
.ClearCircles
.Columns("A:H").AutoFit
.Columns("C:C").Hidden = True
.Rows("1:2").Insert

With .Range("B1:H1")

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.Value = "Synthese Activite Calculs RTR DIEC"
.Font.Name = "Calibri"
.Font.Size = 16
.Font.Bold = True
End With

With .Range("A2:J2")

.Value = Array("Perimetre", "Projet", "", "Jalon", "Calcul", "Etat", "Resource", "", "", "Nb. Jours")

With .Font

.Bold = True
.Color = -16764007
.TintAndShade = 0
End With

.AutoFilter
End With

With .Range("G2:I2")

.MergeCells = True
.HorizontalAlignment = xlCenter
End With

With .Range("A3:L" & r1 + 2).Font

.Name = "Calibri"
.Size = 11
.Bold = True
End With

With .Range("C1:C500")

.Value = .Value
End With
End With

Application.ScreenUpdating = True
End Sub[/VBA]