[VBA]Option Explicit

Public Sub WeeklySummary()
Dim arl As Long
Dim sem As String

sem = Application.InputBox(prompt:="Input week number", Title:="Week number")
If sem <> "False" Then

arl = WorksheetFunction.Match("S" & sem, Worksheets("DATA").Range("I29:GJ29"), 0) + 8
Call SyntheseActivite(arl, 5)
End If
End Sub

Public Sub MonthlySummary()
Dim arl As Long
Dim cell As Range

Set cell = Application.InputBox(prompt:="Select the month cell in row 28 using the mouse", Title:="Month", Type:=8)
If Not cell Is Nothing Then

Call SyntheseActivite(cell.Column, Application.Evaluate("SUMPRODUCT(--(MONTH(30:30)=" & Month(cell.Offset(2).Value) & "))"))
End If
End Sub

Sub SyntheseActivite(ByVal col As Long, ByVal days As Long)
Dim onecell As Range, ar As Range
Dim vv As String, cini As String, a1 As String, cfin As String
Dim ri, RowT As Long, EndR As Long, mlt As Long
Dim rFormula As Variant

Application.ScreenUpdating = False

Worksheets("Synthese Activite").Cells.Clear

With Worksheets("DATA")
ri = 1
mlt = 1

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

If WorksheetFunction.Sum(onecell.Resize(1, days)) > 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" & col & ":R[" & onecell.Row - ri & "]C" & col + days - 1 & ")"

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, "J").Value = "=" & .Cells(RowT, "J").Value & "+" & .Cells(onecell.Row, "J").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" & ri + 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]