Option Explicit
Public daten As Collection
Public import As Range
Public auswertung As Range
Public pos_aus As Long
Public sumString As String
Sub teilsummen()
Set import = Sheets("Import").Range("A1")
Set auswertung = Sheets("Auswertung").Range("A1")
Set daten = New Collection
pos_aus = 1
sumString = ""
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
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)"
If sumString = "" Then
sumString = "="
Else
sumString = sumString & "+"
End If
sumString = sumString & "R" & last + 1 & "C2"
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 Range(zelle).Column = 2 Then
auswertung.Range(zelle).Formula = sumString
End If
End If
End Function
|