Alles ist möglich ;-)

Option Explicit

Public daten As Collection
Public import As Range
Public auswertung As Range
Public pos_aus As Long
Public adrTeilErg() As Variant

Sub teilsummen()

Set import = Sheets("Import").Range("A1")
Set auswertung = Sheets("Auswertung").Range("A1")
Set daten = New Collection

ReDim adrTeilErg(1)

adrTeilErg(1) = ""
pos_aus = 1

auslesen einlesen

Set import = Nothing
Set auswertung = Nothing
Set daten = Nothing

End Sub


Function einlesen()

Dim einZeil As Long
Dim aktzeil As String

einZeil = 1
aktzeil = import.Cells(einZeil, 1).Value

While aktzeil <> ""

On Error Resume Next

aktzeil = daten(aktzeil)
If Err.Number <> 0 Then
   daten.Add aktzeil, aktzeil
End If
einZeil = einZeil + 1
aktzeil = import.Cells(einZeil, 1).Value
Wend
einlesen = einZeil - 1
End Function

Function auslesen(elemente)

Dim head As Long
Dim data As Long
Dim akt As Double
Dim vonAdr As Long

vonAdr = 1
 
 For head = 1 To daten.Count
    For data = 1 To elemente
        
        If CStr(import.Cells(data, 1).Value) = CStr(daten(head)) Then
        akt = import.Cells(data, 2).Value
        out auswertung.Cells(pos_aus, 1).Address, "'" & CStr(daten(head)), 0
        out auswertung.Cells(pos_aus, 2).Address, akt, 0
        pos_aus = pos_aus + 1
        End If
    Next

out auswertung.Cells(pos_aus, 1).Address, "'" & CStr(daten(head)), 1
out auswertung.Cells(pos_aus, 2).Address, 0, 1, vonAdr

vonAdr = auswertung.Cells(pos_aus, 2).Row + 2
pos_aus = pos_aus + 2

Next

pos_aus = pos_aus + 1
out auswertung.Cells(pos_aus, 1).Address, "Gesamt", 2
out auswertung.Cells(pos_aus, 2).Address, 0, 2
End Function



Function out(zelle, wert, linie, Optional vonAdr = "")
Dim last As Long
Dim neu As Long
Dim dl As Long
Dim sumString As String

If vonAdr = "" Then
    auswertung.Range(zelle) = wert
Else
    last = auswertung.Range(zelle).Row - 1
    auswertung.Range(zelle).FormulaR1C1 = "=sum(R" & vonAdr & "C2:R" & last & "C2)"

    neu = UBound(adrTeilErg) + 1
    ReDim Preserve adrTeilErg(neu)
    adrTeilErg(neu - 1) = last + 1
End If

If linie <> 0 Then
    With auswertung.Range(zelle)
        .Font.Bold = True
        .Borders(xlTop).LineStyle = xlContinuous
    End With
End If

If linie = 2 Then
    auswertung.Range(zelle).Borders(xlEdgeBottom).LineStyle = xlDouble
    If auswertung.Range(zelle).Column = 2 Then
        sumString = "="
        For dl = 1 To UBound(adrTeilErg) - 1
            sumString = sumString & "R" & adrTeilErg(dl) & "C2+"
        Next
        sumString = Mid(sumString, 1, Len(sumString) - 1)
        auswertung.Range(zelle).Formula = sumString
        
    End If
End If

End Function