Re,
Une proposition à étudier.
Cdlt.
Option Explicit
Sub CopyToHygL1()
Dim wsData As Worksheet, wsDestination As Worksheet
Dim rng As Range, rCell As Range
Set wsData = Worksheets("SCHEDULE")
Set wsDestination = Worksheets("HYG L1")
With wsData.ListObjects(1)
If .ShowAutoFilter Then .AutoFilter.ShowAllData
.Range.AutoFilter field:=10, Criteria1:="HYG L1"
With .AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
End With
If rng Is Nothing Then
MsgBox "Il n'y a pas de données correspondantes au critère " & "HYG L1" & "."
Exit Sub
Else
With wsDestination.ListObjects(1)
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
Set rCell = .InsertRowRange.Cells(1)
End With
Set rng = wsData.ListObjects(1).AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
With rCell
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
End With
With wsDestination.ListObjects(1)
.Sort.SortFields.Add .ListColumns(8).DataBodyRange, xlSortOnValues, xlAscending
.Sort.Apply
.Sort.SortFields.Clear
End With
wsData.ListObjects(1).Range.AutoFilter field:=10
End If
End Sub