Sum subtotals within dynamic ranges vba

I'm trying to find a way for sum subtotals. subtotals image

As you could see in the pic. i have a column with key codes that allows me to use Find. for looking through all values (in column o) and selecting those that belong to its corresponding section. The issue is that because my poor knowledge in VBA, I was trying long without success. The time has come for asking for some help. Here as follows some hints about what I was doing/trying. As you can see here, I was trying with Find. for looking values in column "O". After that, I was not capable to select them for sum.

Sub Mod9x()
    Dim cell As Range
    Dim arr As Variant, arrElem1 As Variant
    Dim firstAddress As String, c As Range, rALL As Range
    Dim sh1 As Worksheet
    Dim i, j As Long, r As Range, d As Double

    Set sh1 = Sheets("Valeurs")
    lr = sh1.Range("E" & Rows.Count).End(xlUp).row

    For i = 15 To lr
        With sh1
            On Error Resume Next
            For Each cell In sh1.Cells(i, 5)
                arr = Split(Replace(cell.Value, "  ", " "), " ")
                For Each arrElem1 In arr
                    If Len(arrElem1) = 15 Then
                        lResult1 = arrElem1
                        Set Findv1 = Range("E15:E3000").Cells.Find(What:=lResult1, LookAt:=xlWhole, _
                          After:=Range("E15"), SearchDirection:=xlNext)
                        If Not Findv1 Is Nothing Then
                            With Findv1
                                Set c = .Find(Findv1, LookIn:=xlValues, LookAt:=xlPart)
                                If Not c Is Nothing Then
                                    Set rALL = c
                                    firstAddress = c.Address
                                    Do

                                        Set rALL = Union(rALL, c)
                                        sh1.Range(c.Address).Activate
                                        Set c = .FindNext(c)

                                    Loop While Not c Is Nothing And c.Address <> firstAddress
                                End If

                                .Activate
                                If Not rALL Is Nothing Then c.Offset(, 10).Select
                                Application.WorksheetFunction.sum (Selection)

                                sh1.Cells(Findv1, 15) = Application.WorksheetFunction.sum(Selection)

                            End With


                        End If
                    End If
                Next arrElem1
            Next cell
        End With
    Next i
End Sub

Really grateful for any support.

Additional code for Key values finding:

    Sub x()

Dim r As Range, d As Double

For Each r In Columns(5).SpecialCells(xlCellTypeConstants)
    If UBound(Split(r, ".")) = 3 Then
        d = d + r.Offset(, 10).Value
        r.Offset(, 10).Value = d
    End If
Next r

End Sub