Microsoft Excel

Herbers Excel/VBA-Archiv

Listen-Aufstellung filtern und summieren

Betrifft: Listen-Aufstellung filtern und summieren von: Tobi
Geschrieben am: 12.06.2008 15:50:01

Hallo zusammen,
trotz intensiver Suche komme ich leider auf keinen grünen Zweig...
ich versuche mal mein Anliegen zu schildern:

https://www.herber.de/bbs/user/53023.xls

Das steht auf Seite 1:

Kategorie A
Text_A3: 5
Freitext bla bla
Text_A8: 2

Kategorie B
Text_B1: 17
Freitext bla bla
Text_B21: 5

Kategorie A
Text_A4: 6
Text_A8: 2

Das soll auf Seite 2 stehen:

Kategorie A
Text_A3: 5
Text_A4: 6
Text_A8: 4

Kategorie B
Text_B1: 17
Text_B21: 5

So, das mag wohl unübersichtlich aussehen. Also es geht darum: Auf Seite 1 werden verschiedene Arbeitsabläufe chronologisch zusammengeschrieben. Das besteht zum Einen aus Textbausteinen mit dazugehörigen Mengen und Einheiten (also z.B. "Datenanlage: 2,5 h" etc. etc.) und zum Anderen aus erklärenden Freitexten dazwischen.
Der Anwender kann also verschiedenste Positionen wild durcheinander reinhacken.

Und auf Seite 2 soll die Rechnung dazu rauskommen :-)
Diese soll zum einen die (vorhandenen) Überkategorien sortieren und zum anderen nur (!) die Mengen hinter den (vorhandenen) Textbausteinen zusammenzählen.

Ach ja: ich kann Excel ziemlich gut, jedoch keinerlei VB Script.

  

Betrifft: AW: Listen-Aufstellung filtern und summieren von: fcs
Geschrieben am: 12.06.2008 19:13:11

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




 

Beiträge aus den Excel-Beispielen zum Thema "Listen-Aufstellung filtern und summieren"