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