Private Sub CommandButton1_Click()
Dim cel As Range, zone As Range, P As Range, c As Range
Application.ScreenUpdating = False
Set cel = [B6]
With Sheets("Feuil1")
Set zone = .[B6:B59].SpecialCells(xlCellTypeConstants, 1)
While Application.CountA(.[C:C])
Set P = .[A1:C5,A60:C61]
For Each c In zone
If c(1, 2) = 1 Then Set P = Union(P, c(1, 0).MergeArea.Resize(, 3))
Next
P.Copy cel
.[C:C].Delete
Set cel = [B65536].End(xlUp)(4)
Wend
End With
End Sub