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

Option Explicit
Sub ProdPrévuEtUnAjustementModuleDeClasseCollectionDansModuleDeClasse()
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"
                   Refvolet.Item TBase(i, 1), TBase(i, 3)
                Case "Ajustement prod"
                    Refvolet.Item TBase(i, 1), TBase(i, 3)
            End Select
        End If
Next i
' récupération des exemplaires stocké dans la Variable Collection !
Dim NbVoletProd As Article
Dim coll As Collection
On Error Resume Next
For i = LBound(TNomenclatures, 1) To UBound(TNomenclatures, 1)
    If TNomenclatures(i, 1) <> Empty Then
        Set coll = Refvolet.Conteneur
        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 MclRes As Variant
Private MclRecopieRes As Variant
Private coll As Collection
Private Sub Class_Initialize()
   Set coll = New Collection
   End Sub
Public Function Item(ByVal Rub As Variant, Optional ByVal Res As Variant) As Article
On Error Resume Next
    Set Item = coll(Rub)
If Err.Number <> 0 Then
    Set Item = New Article
    MclRes = Empty
    Item.Resultat = Res
    coll.Add Item, Rub
Else
    Item.Resultat = Res
End If
On Error GoTo 0
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
Property Get Conteneur() As Collection
   Set Conteneur = coll
   End Property