Microsoft 365 Rassembler les données de plusieurs feuilles dans une feuille récapitulative

Option Explicit

Sub Recapitulation()
   Dim ws As Worksheet, dl As Long, dl2 As Long, Fr As Worksheet, c As Range
   Set Fr = ThisWorkbook.Worksheets("recap")
   Application.ScreenUpdating = False
   With Fr
      dl = .Cells(Rows.Count, 1).End(xlUp).Row
      If dl > 5 Then .Range(.Cells(6, 1), .Cells(dl, 12)).ClearContents
   End With

   For Each ws In Worksheets
      If ws.Name <> "RECAP" Then
         dl2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
         If dl2 > 5 And ws.Cells(dl2, 1) <> "" Then
            For Each c In ws.Range(ws.Cells(6, 1), ws.Cells(dl2, 1))
               dl = Fr.Cells(Rows.Count, 1).End(xlUp).Row + 1
               Fr.Cells(dl, 1) = c
               Fr.Cells(dl, 2) = c.Offset(0, 1)
               Fr.Cells(dl, 3) = ws.Name
               Fr.Cells(dl, 4) = c.Offset(0, 2)
               Fr.Cells(dl, 5) = c.Offset(0, 3)
               Fr.Cells(dl, 6) = c.Offset(0, 4)
               Fr.Cells(dl, 7) = c.Offset(0, 5)
               Fr.Cells(dl, 8) = c.Offset(0, 6)
               Fr.Cells(dl, 9) = c.Offset(0, 7)
               Fr.Cells(dl, 10) = c.Offset(0, 8)
               Fr.Cells(dl, 11) = c.Offset(0, 9)
               Fr.Cells(dl, 12) = c.Offset(0, 10)
            Next c
         End If
      End If
   Next
   Application.ScreenUpdating = True
   MsgBox "Recap terminée!", vbInformation + vbOKOnly, "TRAITEMENT"

End Sub