Sub SupprLignesEtCopie()
Dim wsh As Worksheet, derLig0&, xarea As Range
Dim Source As Range, laBas As Range, n&
Application.ScreenUpdating = False
With Worksheets("Base")
.Activate
Set Source = Intersect(Selection.EntireRow, .Range("a:h").EntireColumn)
End With
For Each wsh In ThisWorkbook.Worksheets
If wsh.Index > Worksheets("Base").Index Then
With wsh
On Error Resume Next: derLig0 = 0
derLig0 = Application.WorksheetFunction.Match(999, .Range("h:h"), 1)
On Error GoTo 0
If derLig0 > 1 Then .Rows(1).Resize(derLig0 - 1).Delete
For Each xarea In Source.Areas
n = .Cells(.Rows.Count, "a").End(xlUp).Row
If n = 1 And .Cells(1, "a") = "" Then n = n - 1
n = n + 1
xarea.Copy .Cells(n, "a")
.Columns(1).NumberFormat = "dd/mm/yyyy"
Next xarea
Application.Goto .Range("a1"), True
End With
End If
Next wsh
End Sub