XL 2016 Transfert de données d'un onglet à un autre avec condition.

Option Explicit
Private mdl As Article
Private Coll As Collection
Private MclRes As Variant
Private MclRecopieRes As Variant
Public Sub InitCollection()
    Set Coll = New Collection
   End Sub
Public Sub Item(ByVal Rub As Variant, Optional ByVal Res As Variant)
Debug.Print Rub
On Error Resume Next
    Set mdl = Coll(Rub)
If Err.Number <> 0 Then
    Me.InitCollection
    MclRes = Empty
    Me.Resultat = Res
    Coll.Add Me, Rub
Else
    Me.Resultat = Res
End If
On Error GoTo 0
End Sub

Dim Refvolet As New Article     ' Equivalent de Redim preserve conserve les contenant
    'Set Refvolet = New Article ' Equivalent de Redim avec les tableaux perd le contenant
Dim coll As New Collection      ' Equivalent de Redim preserve conserve les contenant
    'Set coll = New Collection  ' Equivalent de Redim avec les tableaux perd le contenant

Option Explicit
Sub ProdPrévuEtUnAjustementModuleDeClasse()
Dim Refvolet As New Article     ' Equivalent de Redim preserve conserve les contenant
    'Set Refvolet = New Article ' Equivalent de Redim avec les tableaux perd le contenant
Dim coll As New Collection      ' Equivalent de Redim preserve conserve les contenant
    'Set coll = New Collection  ' Equivalent de Redim avec les tableaux perd le contenant
Dim wkb As Workbook
    Set wkb = Workbooks(ThisWorkbook.Name)
Dim wksBase As Worksheet
Dim wksNomenclatures As Worksheet
    Set wksBase = wkb.Worksheets("Base")
    Set wksNomenclatures = wkb.Worksheets("Nomenclatures")
Dim TBase, TNomenclatures As Variant
    TBase = wksBase.Range(wksBase.Cells(2, 1), wksBase.Cells(wksBase.Cells(65536, 1).End(xlUp).Row, 3)).Value2
    TNomenclatures = wksNomenclatures.Range(wksNomenclatures.Cells(2, 1), wksNomenclatures.Cells(wksNomenclatures.Cells(65536, 1).End(xlUp).Row, 3)).Value2
    ReDim Preserve TNomenclatures(LBound(TNomenclatures, 1) To UBound(TNomenclatures, 1), LBound(TNomenclatures, 2) To UBound(TNomenclatures, 2) + 1)
Dim Rgn As Range
Dim i As Integer
For i = LBound(TBase, 1) To UBound(TBase, 1)
     Set Rgn = wksBase.Range(wksBase.Cells(i + 1, 3), (wksBase.Cells(i + 1, 3)))
        If Rgn.Interior.ColorIndex = 4 Then
            Select Case TBase(i, 2)
                Case "Prod prévue"
                   Set coll = Refvolet.Item(TBase(i, 1), coll, TBase(i, 3))
                Case "Ajustement prod"
                    Set coll = Refvolet.Item(TBase(i, 1), coll, TBase(i, 3))
            End Select
        End If
Next i
On Error Resume Next
Dim NbVoletProd As Article
For i = LBound(TNomenclatures, 1) To UBound(TNomenclatures, 1)
    If TNomenclatures(i, 1) <> Empty Then
        Set NbVoletProd = coll.Item(TNomenclatures(i, 1))
            TNomenclatures(i, 4) = NbVoletProd.Resultat
        Set NbVoletProd = Nothing
    End If
Next i
On Error GoTo 0
    wksNomenclatures.Cells(2, 4).Resize(UBound(TNomenclatures, 1), 1).Value = Application.Index(TNomenclatures, , 4)
End Sub

Option Explicit
Private mdl As Article
Private MclRes As Variant
Private MclRecopieRes As Variant
Public Function Item(ByVal Rub As Variant, ByVal coll As Collection, Optional ByVal Res As Variant) As Collection
Dim MclTemp As Article
Debug.Print Rub
On Error Resume Next
    Set mdl = coll(Rub)
If Err.Number <> 0 Then
    Set MclTemp = New Article
    MclRes = Empty
    MclTemp.Resultat = Res
    coll.Add MclTemp, Rub
Else
    mdl.Resultat = Res
End If
On Error GoTo 0
Set Item = coll
End Function
Property Let Resultat(ByVal Res As Variant)
   MclRes = MclRes + Res
   Debug.Print MclRes
   End Property
Property Get Resultat() As Variant
   Resultat = MclRes
   End Property

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, tablo, i&, v, x$, P As Range, resu()
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Base").UsedRange.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 2) <> "Reste à fabriquer" Then
        v = tablo(i, 3)
        If IsNumeric(v) Then x = CStr(tablo(i, 1)): d(x) = d(x) + CDbl(v)
    End If
Next
'---tableau des résultats---
Set P = UsedRange
tablo = P.Resize(, 4) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 1)
resu(1, 1) = tablo(1, 4)
For i = 2 To UBound(resu)
    x = CStr(tablo(i, 1))
    If d.exists(x) Then resu(i, 1) = d(x)
Next
'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
P(1, 4).Resize(UBound(resu)) = resu
Application.EnableEvents = True 'réactive les évènements
End Sub

'---tableau des résultats---
Set P = UsedRange
tablo = P.Resize(, 4) 'matrice, plus rapide
'ReDim resu(1 To UBound(tablo), 1 To 1)
'resu(1, 1) = tablo(1, 4)
For i = 2 To UBound(tablo, 1)
    x = CStr(tablo(i, 1))
    If d.exists(x) Then tablo(i, 4) = d(x)
Next
'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
'P(1, 4).Resize(UBound(resu)) = resu
P.Cells(1, 4).Resize(UBound(tablo, 1), 1).Value = Application.Index(tablo, , 4)
Application.EnableEvents = True 'réactive les évènements

'---tableau des résultats---
Set P = UsedRange
tablo = P.Resize(, 4) 'matrice, plus rapide
On Error Resume Next
For i = 2 To UBound(tablo, 1)
    tablo(i, 4) = d(CStr(tablo(i, 1)))
Next
On Error GoTo 0

'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
P.Cells(1, 4).Resize(UBound(tablo, 1), 1).Value = Application.Index(tablo, , 4)
Application.EnableEvents = True 'réactive les évènements