Bonjour,
Ci-dessous, la procédure modifiée.
Cdlt.
Option Explicit
Option Private Module
Public Sub ConsolidateData()
Dim wb As Workbook
Dim ws As Worksheet, wsCost As Worksheet, wsResult As Worksheet
Dim tblResult As ListObject
Dim tbl, Arr(), V
Dim I As Long, J As Long, k As Long, lCol As Long
Dim rngCost As Range, rCell As Range
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Set wsCost = wb.Worksheets("Coût")
Set rngCost = wsCost.ListObjects(1).Range
Set wsResult = wb.Worksheets("Résultat")
Set tblResult = wsResult.ListObjects(1)
With tblResult
If Not .DataBodyRange Is Nothing Then _
.DataBodyRange.Delete
Set rCell = .InsertRowRange.Cells(1)
End With
k = 0: lCol = 2
For Each ws In wb.Worksheets
If ws.Name <> wsCost.Name And ws.Name <> wsResult.Name Then
tbl = ws.ListObjects(1).Range.Value
For I = 2 To UBound(tbl, 1)
For J = 2 To UBound(tbl, 2)
If tbl(I, J) <> vbNullString Then
ReDim Preserve Arr(6, k + 1)
Arr(0, k) = ws.Name 'Nom feuille
Arr(1, k) = tbl(I, 1) 'Requête
Arr(2, k) = tbl(1, J) 'Produit
Arr(3, k) = tbl(I, J) 'Quantité
V = Application.WorksheetFunction. _
VLookup(tbl(1, J), rngCost, lCol, 0) 'Coût
If IsError(V) Then
Arr(4, k) = "": Arr(5, k) = ""
Else
Arr(4, k) = V: Arr(5, k) = tbl(I, J) * V 'Coût total
End If
k = k + 1
End If
Next J
Next I
End If
lCol = lCol + 1
Next ws
rCell.Resize(UBound(Arr, 2), 6).Value = Application.Transpose(Arr)
wsResult.PivotTables(1).PivotCache.Refresh
Erase Arr()
Set rCell = Nothing: Set rngCost = Nothing
Set tblResult = Nothing
Set wsResult = Nothing: Set wsCost = Nothing
Set wb = Nothing
End Sub