Une proposition (tout automatique)
Private Sub Worksheet_Activate()
COMPIL
End Sub
Sub COMPIL()
Dim f As Worksheet, result()
n = 1
ReDim result(1 To 5, 1 To 1)
For Each f In Worksheets
If Len(f.Name) = 1 Then
tbl = f.UsedRange.Value
For i = 4 To UBound(tbl) Step 5
For j = 2 To UBound(tbl, 2)
If tbl(i, j) <> "" And tbl(i + 1, j) <> "" Then
result(1, n) = tbl(i, j)
result(2, n) = tbl(i + 1, j)
result(3, n) = tbl(i + 2, j)
result(4, n) = tbl(i + 3, j)
result(5, n) = tbl(i + 4, j)
n = n + 1
ReDim Preserve result(1 To 5, 1 To n)
End If
Next
Next
End If
Next
ReDim Preserve result(1 To 5, 1 To n - 1)
With Sheets("Récap")
If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete
.Cells(2, 1).Resize(UBound(result, 2), 5) = Application.Transpose(result)
End With
TRIER
End Sub
Sub TRIER()
ActiveWorkbook.Worksheets("Récap").ListObjects("Tableau1").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Récap").ListObjects("Tableau1").Sort.SortFields.Add _
Key:=Range("Tableau1[Référence]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Récap").ListObjects("Tableau1").Sort.SortFields.Add _
Key:=Range("Tableau1[Date d''entrée]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Récap").ListObjects("Tableau1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub