Referencing multiple dic.items in dictionary to clean up my code

I am currently using two dictionaries in one code, which works, but was wandering whether the code could be cleaned up so as to execute the same series of events using only one dictionary. I prefer to keep codes to a minimum if I can.

Essentially, the code checks one sheet for a product code. It then 'copies' the product code and data from two specific columns in the same row. If there are multiple of the same product code it will accumulate the data in the other two columns the 'end product' is just one row with the product code and accumulated totals adjacent.

Here is the code....what I am trying to do would be combine dic and dic2, but I cannot work out how...

Sub forforum()

Dim Orders As Variant
Dim i As Long
Dim dic As Object
Dim dic2 As Object
Dim Criteria As Variant
Dim Criteria2 As Date
Dim Criteria3 As Date
Dim Quantity As Variant
Dim Code As String
Dim Keys As Variant
Dim OrderDate As Date
Dim Subtotal As Variant

Application.ScreenUpdating = False
Criteria = Sheets("Sheet2").Range("D3").Value2
Criteria2 = Sheets("Sheet2").Range("D4").Value2
Criteria3 = Sheets("Sheet2").Range("D5").Value2

    With Sheets("Sheet1")
    
        Orders = .Range("a3:j" & .Cells(.Rows.Count, "d").End(xlUp).Row).Value
    
        Set dic = CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(Orders, 1)
                Code = Orders(i, 8)
                Quantity = Orders(i, 9)
                OrderDate = Orders(i, 4)
                
            If Code = Criteria And OrderDate >= Criteria2 And OrderDate <= Criteria3 Then
                If dic.Exists(Code) Then
                
                dic.Item(Code) = dic.Item(Code) + Quantity
                
                Else
                dic.Add Code, Quantity
                End If
            End If
            Next
    End With
    
    With Sheets("Sheet2")
        Keys = dic.Keys
        If dic.Count Then
            .Range("f2").Resize(dic.Count, 2).Value = Application.Transpose(Keys)
            For i = 0 To UBound(Keys)
            .Cells(i + 2, "g") = dic.Item(Keys(i))
            Next
        End If
  End With
    
    With Sheets("Sheet1")
    
    Orders = .Range("a3:j" & .Cells(.Rows.Count, "d").End(xlUp).Row).Value
    
     Set dic2 = CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(Orders, 1)
                Code = Orders(i, 8)
                Quantity = Orders(i, 9)
                Subtotal = Orders(i, 10) * Orders(i, 9)
                OrderDate = Orders(i, 4)
                
            If Code = Criteria And OrderDate >= Criteria2 And OrderDate <= Criteria3 Then
                If dic2.Exists(Code) Then
                
                dic2.Item(Code) = dic2.Item(Code) + Subtotal
                
                Else
                dic2.Add Code, Subtotal
                End If
            End If
            Next
    End With
    
    With Sheets("Sheet2")
        Keys = dic2.Keys
        If dic.Count Then
            .Range("h2").Resize(dic.Count, 1).Value = Application.Transpose(dic2.Items)
        End If
    End With
    

Set dic = Nothing
Set dic2 = Nothing
Application.ScreenUpdating = True
End Sub