Bonjour,
Une proposition à étudier.
Cdlt.
Private Sub cmdConsolidateData_Click()
Dim ws As Worksheet
Dim rCell As Range
Dim lCol As Long, Lrow As Long, I As Long, k As Long
Dim tbl As Variant, Arr() As Variant
Application.ScreenUpdating = False
'-------------------------------------------------------------------
With Me.ListObjects(1)
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
Set rCell = .InsertRowRange.Cells(1)
End With
'-------------------------------------------------------------------
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> Me.Name Then
With ws
lCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
tbl = .Cells(5, 1).Resize(Lrow - 4, lCol)
End With
End If
k = 0
For I = 1 To UBound(tbl)
If tbl(I, 10) <> "" Then
ReDim Preserve Arr(10, k + 1)
Arr(0, k) = CLng(tbl(I, 12))
Arr(1, k) = tbl(I, 1)
Arr(2, k) = tbl(I, 2)
Arr(3, k) = tbl(I, 8)
Arr(4, k) = tbl(I, 3)
Arr(5, k) = tbl(I, 11)
Arr(6, k) = tbl(I, 4)
Arr(7, k) = tbl(I, 5)
Arr(8, k) = tbl(I, 6)
Arr(9, k) = tbl(I, 14)
k = k + 1
End If
Next I
Next ws
'-------------------------------------------------------------------
rCell.Resize(UBound(Arr, 2), 10).Value = Application.Transpose(Arr)
'-------------------------------------------------------------------
Erase Arr
Set rCell = Nothing
End Sub