Excel, extraire des ligne sur autre onglet

Sub rapatrier()   
 Voir + bas 
End Sub

Sub rapatrier() 
Dim nbre_f As Byte, cptr_f As Byte, lig_vide As Byte 
Dim nbre As Byte, cptr As Byte, lig As Byte, hauteur As Single 
Dim nonfait 

'initialisation 
Application.ScreenUpdating = False 
nbre_f = ThisWorkbook.Sheets.Count 
lig_vide = 7 
 With Sheets("A faire") 
     .Range("B7:D260").Clear 
     .Rows("7:260").RowHeight = 14 
End With 
'compilation 
For cptr_f = 2 To nbre_f - 1 
     With Sheets(cptr_f) 
          If Name <> "list" And .Name <> "A faire" Then 
               essai = .Name 
               nbre = Application.CountIf(.Range("E7:E260"), "A faire") 
               lig = 6 
               For cptr = 1 To nbre 
                    lig = .Columns("E").Find("A faire", .Cells(lig, "E")).Row 
                    hauteur = .Rows(lig).RowHeight 
                    nonfait = .Range(.Cells(lig, "B"), .Cells(lig, "D")).Value 
                    With Sheets("A faire").Cells(lig_vide, "B").Resize(1, 3) 
                         .Value = nonfait 
                         .RowHeight = hauteur 
                         .VerticalAlignment = xlTop 
                         .WrapText = True 
                    End With 
                    lig_vide = lig_vide + 1 
               Next 
          End If 
     End With 
Next 
Sheets("A faire").Range("B7:D" & lig_vide - 1).Borders.Weight = xlThin 
End Sub 

For Each cel In ActiveSheet.UsedRange 
If cel <> "" Then 
Set m = cel.MergeArea 
m.UnMerge 
m.WrapText = True 'renvoie à la ligne 
m.HorizontalAlignment = xlCenterAcrossSelection 
m.Rows.AutoFit 
m.Merge 
m.HorizontalAlignment = xlGeneral 'facultatif bien sûr 
End If 
Next