Sub synthese()
Dim WBS(1 To 2) As Workbook
Dim C As Range
Dim I As Integer, R As Integer, WB As Integer, DestRow As Integer
Dim strRange As String, F As Variant
Dim TEST As Boolean
Dim NoMoreTeam As Boolean
'referencer les classeurs
Set WBS(1) = GetObject(ActiveWorkbook.Path & "\1.xls")
Set WBS(2) = GetObject(ActiveWorkbook.Path & "\2.xls")
'parcourir les feuilles
Application.ScreenUpdating = False
For WB = 1 To 2
For Each F In Array("LUNDI", "MARDI", "MERCREDI")
NoMoreTeam = False
R = 7
Do Until NoMoreTeam
strRange = Replace("H%:S%", "%", CStr(R))
For Each C In WBS(WB).Sheets(F).Range(strRange)
If UCase(C) = "X" Then TEST = True
Next C
If TEST Then
WBS(WB).Sheets(F).Rows(R).Copy
ActiveWorkbook.Sheets(F).Range("B65536").End(xlUp).Offset(1, -1).PasteSpecial
End If
R = R + 1
If WBS(WB).Sheets(F).Cells(R, 2) = "" Then NoMoreTeam = True
TEST = False
Loop
Next F
Set WBS(WB) = Nothing
Next WB
Application.ScreenUpdating = True
End Sub