AW: Listen-Aufstellung filtern und summieren
12.06.2008 19:13:11
fcs
Hallo Tobi,
hier mein Vorschlag,
die Daten werden erst in eine neue Tabelle übertragen, so das Jede Zeile einen Eintrag
Kategorie
Text
Wert
Anmerkung hat
Dann werden die Daten sortiert und in einer weiteren Tabelle neu gruppiert. Diese Umgruppierung könnte man natürlich auch mit einem Pivot-Tabellenbericht machen.
Gruß
Franz
Sub aaaTest()
Call EingabeAufbereiten
Call NeuGruppieren
End Sub
Private Sub EingabeAufbereiten()
Dim wksEingabe As Worksheet
Dim wksAusgabe As Worksheet
Dim strKategorie As String
Dim strText As String
Dim strBlabla As String
Dim dblBetrag As Double
Dim lngZeileEin As Long, lngLetzteEin As Long
Dim lngZeileAus As Long
Set wksEingabe = Worksheets("Tabelle1")
Worksheets.Add After:=wksEingabe
Set wksAusgabe = ActiveSheet
lngZeileAus = 1
With wksAusgabe
.UsedRange.ClearContents
'Überschriftenzeile
.Cells(lngZeileAus, 1).Value = "Kategorie"
.Cells(lngZeileAus, 2).Value = "Text"
.Cells(lngZeileAus, 3).Value = "Wert"
.Cells(lngZeileAus, 4).Value = "Anmerkung"
End With
With wksEingabe
'letzte Eingabezeile
lngLetzteEin = .Cells(.Rows.Count, 2).End(xlUp).Row
lngZeileEin = 6 '1. Zeile mit Kategorieeintrag, ggf. Anpassen !!!
Do Until lngZeileEin > lngLetzteEin + 1
'Nächste kategorie in Spalte A suchen
Do Until .Cells(lngZeileEin, 1) "" Or lngZeileEin > lngLetzteEin
lngZeileEin = lngZeileEin + 1
Loop
strKategorie = .Cells(lngZeileEin, 1).Value
lngZeileEin = lngZeileEin + 1
'Schleifen bis zum Ende der Einträge für Kategorie
Do Until .Cells(lngZeileEin, 2) = "" Or lngZeileEin > lngLetzteEin
strBlabla = ""
Do Until lngZeileEin > lngLetzteEin
If Not IsEmpty(.Cells(lngZeileEin, 3)) Then
strText = .Cells(lngZeileEin, 2)
dblwert = .Cells(lngZeileEin, 3)
Exit Do
Else
strBlabla = IIf(strBlabla = "", _
.Cells(lngZeileEin, 2), strBlabla & " " & .Cells(lngZeileEin, 2))
lngZeileEin = lngZeileEin + 1
End If
Loop
lngZeileEin = lngZeileEin + 1
Do Until lngZeileEin > lngLetzteEin Or .Cells(lngZeileEin, 2) = ""
If Not IsEmpty(.Cells(lngZeileEin, 3)) Then
Exit Do
Else
strBlabla = IIf(strBlabla = "", _
.Cells(lngZeileEin, 2), strBlabla & " " & .Cells(lngZeileEin, 2))
lngZeileEin = lngZeileEin + 1
End If
Loop
lngZeileAus = lngZeileAus + 1
wksAusgabe.Cells(lngZeileAus, 1).Value = strKategorie
wksAusgabe.Cells(lngZeileAus, 2).Value = strText
wksAusgabe.Cells(lngZeileAus, 3).Value = dblwert
wksAusgabe.Cells(lngZeileAus, 4).Value = strBlabla
Loop
Loop
End With
End Sub
Private Sub NeuGruppieren()
Dim wksNeu As Worksheet
Dim wksAusgabe As Worksheet
Dim objBereich As Range
Dim strKategorie As String
Dim strText As String
Dim dblBetrag As Double
Dim lngZeileNeu As Long, lngLetzteAus As Long
Dim lngZeileAus As Long
Set wksAusgabe = ActiveSheet
lngZeileAus = 1
With wksAusgabe
'daten Sortieren
Set objBereich = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 3))
With objBereich
.Sort key1:=.Range("A1"), order1:=xlAscending, _
key2:=.Range("B1"), order1:=xlAscending, header:=xlNo
End With
lngLetzteAus = .Cells(.Rows.Count, 1).End(xlUp).Row
Worksheets.Add After:=wksAusgabe
Set wksNeu = ActiveSheet
lngZeileNeu = 1
lngZeileAus = 2
strKategorie = .Cells(lngZeileAus, 1)
For lngZeileAus = 2 To lngLetzteAus
wksNeu.Cells(lngZeileNeu, 1) = strKategorie
Do Until .Cells(lngZeileAus, 1) strKategorie
strText = .Cells(lngZeileAus, 2)
dblwert = .Cells(lngZeileAus, 3)
Do Until .Cells(lngZeileAus + 1, 2) strText
lngZeileAus = lngZeileAus + 1
dblwert = dblwert + .Cells(lngZeileAus, 3)
Loop
lngZeileNeu = lngZeileNeu + 1
wksNeu.Cells(lngZeileNeu, 2).Value = strText
wksNeu.Cells(lngZeileNeu, 3).Value = dblwert
lngZeileAus = lngZeileAus + 1
Loop
strKategorie = .Cells(lngZeileAus, 1)
lngZeileNeu = lngZeileNeu + 1
lngZeileAus = lngZeileAus - 1
Next
End With
End Sub