Sub Regroupe()
Dim lig&, w As Worksheet, r As Range, v1, v2$
Application.ScreenUpdating = False
With Sheets("Regroupe") 'nom à adapter
.Rows("4:" & .Rows.Count).Clear 'RAZ
lig = 4 '1ère ligne renseignée
l_en_tete = lig - 1
For Each w In Worksheets
If w.Name <> .Name Then
For Each r In w.UsedRange.Rows
v1 = Intersect(r.EntireRow, w.[b:b])
v2 = Intersect(r.EntireRow, w.[c:c])
If v1 <> "" And v2 <> "" And v1 <> Sheets("Regroupe").Cells(l_en_tete, 2) Then
r.EntireRow.Copy .Cells(lig, 1)
lig = lig + 1
End If
Next
End If
Next
End With
End Sub