Hi

Using your example file as the basis for structure etc.

1) Create a new Class module, called Class1 (this is the default) and enter the code

Public item As String
Public qty As Long
Public costtot As Double
Public costeach As Double
Public datee As Date
2) Enter the code below into a general module

Sub aaa()
  Application.ScreenUpdating = False
  Dim nodupes As New Collection
  
  Sheets("sheet2").Activate
  Range("A3:F" & Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=Range("C3"), order1:=xlAscending, key2:=Range("A3"), order1:=xlAscending
  cntr = 1
  For Each ce In Range("C3:C9")
    Select Case ce.Offset(0, -1).Value
      Case "Bought"
        Set thing = New Class1
        thing.datee = ce.Offset(0, -2)
        thing.item = ce.Value
        thing.qty = ce.Offset(0, 1).Value
        thing.costtot = ce.Offset(0, 2).Value
        thing.costeach = ce.Offset(0, 3).Value
        nodupes.Add item:=thing, key:=CStr(cntr)
        cntr = cntr + 1
      Case "Sold"
        workqty = ce.Offset(0, 1).Value
        For i = 1 To cntr - 1
          If nodupes(i).item = ce.Value Then
            If nodupes(i).qty > workqty Then
              nodupes(i).qty = nodupes(i).qty - workqty
              workqty = workqty - workqty
            ElseIf nodupes(i).qty > 0 Then
              workqty = workqty - nodupes(i).qty
              nodupes(i).qty = 0
            
            End If
          End If
        
        Next i
    End Select
  Next ce
  
  Range("I:M").ClearContents
  
  For i = 1 To nodupes.Count
    outrow = Cells(Rows.Count, "I").End(xlUp).Offset(1, 0).Row
    Cells(outrow, "I").Value = nodupes(i).item
    Cells(outrow, "J").Value = nodupes(i).qty
    Cells(outrow, "K").Value = nodupes(i).costeach
  Next i
  
  lastrow = Cells(Rows.Count, "I").End(xlUp).Row
  
  Sheets("Sheet1").Activate
  Range("F3").Formula = "=SUMPRODUCT(--(Sheet2!$I$2:$I$" & lastrow & "=Sheet1!A3),(Sheet2!$J$2:$J$" & lastrow & "),(Sheet2!$K$2:$K$" & lastrow & "))"
  Range("F3").AutoFill Destination:=Range("F3:F" & Cells(Rows.Count, 1).End(xlUp).Row)
  Application.ScreenUpdating = True
End Sub
There is some output on sheet2 columns I-K that is used in the new sumproduct formulas.

HTH

rylo