I just changed some column numbers - see if it works:

Sub SteinVII_IP(): Dim P, Q, r As Long, S As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: S = 2
                Set wa = Sheets("Database (2)")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.Cells(3, 1).CurrentRegion: wa.UsedRange.Offset(2).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2) + 1)
        With CreateObject("Scripting.Dictionary")
            For r = 4 To UBound(P, 1)
    ID = P(r, 1) & "|" & P(r, 3) & "|" & P(r, 6) & "|" & P(r, 8)
            P(r, 9) = P(r, 7) * P(r, 9)
            If ID <> "" Then
        If .Exists(ID) Then
    k = .Item(ID): Q(k, 7) = Q(k, 7) + P(r, 7): Q(k, 9) = Q(k, 9) + P(r, 9)
        Else: .Item(ID) = S
        For n = 1 To UBound(P, 2): Q(S, n) = P(r, n): Next n: S = S + 1
        End If
        Else
        For n = 1 To UBound(P, 2): Q(S, n) = P(r, n): Next n: S = S + 1
        End If: Next r: k = S
        For r = 2 To S - 1: Q(r, 9) = Q(r, 9) / Q(r, 7): Next r
        wa.Cells(3, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub