Office: (Office 2016) Tabellen zusamenkürzen

@RPP63 : Hallo Ralf, ich hatte deinen Lösungsvorschlag schon versucht. Leider habe ich eine Rückmeldung versäumt, sry :-(
Ich bin auf 2 Probleme gestoßen.
Zum Einen kann ich deine Excel-Tabelle nicht herunterladen, weil ich auf meinem Arbeitsrechner dazu keine Berechtigung habe. Das könnte ich allerdings von zuhause machen.
Das größere Problem ist, dass eine Umwandlung der 6 MB großen Tabelle nach 1.048.000 geladenen Zeilen abgebrochen wird und mir eine Fehlermeldung mitteilt, dass mein Arbeitsspeicher von 8 GB nicht ausreichen würde ...
Könnte aber auch das zuhause mit 64 GB noch mal versuchen :-)

@Beverly : Hi Beverly, die eigentliche Tabelle kann ich nicht hochladen, weil sie personenbezogene Daten enthält und recht groß ist. Ich habe mal die obere linke Ecke der ersten Haupttabelle rauskopiert und hier hochgeladen. Ich hoffe, das ist ausreichend.
Ich will nach den Kursen "Pmd", "Pkt" und "PrW" suchen. Bei diesen hätte ich gerne in der per Makro neu zu erstellenden Tabelle gewusst, welche Gruppen (mit wie vielen Teilnehmern - die Zahl links daneben) an welchem Tag einen dieser Kurse besuchen / besucht haben.

Ich finde es übrigens großartig, wie ihr euch hier kümmert !

LG

 

Die hochgeladene Mappe war ausreichend um deinen Tabellenaufbau nachvollziehen zu können. Mit dem folgenden Code sollte es jetzt funktionieren:

Code:

Sub Zusammenfassen()
    Dim intSpalte As Integer
    Dim lngZeile As Long
    Dim intLetzte As Integer
    Dim lngLetzte As Long
    Application.ScreenUpdating = False
    ActiveSheet.Copy after:=ActiveSheet
    With ActiveSheet
        lngLetzte = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        intLetzte = .Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        .Range(.Cells(1, 8), .Cells(lngLetzte, intLetzte)).Copy
        .Range("H1").PasteSpecial Paste:=xlValues
        For lngZeile = lngLetzte To 6 Step -1
            If .Cells(lngZeile, 2) <> "" Then
                If Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "Pkt") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "Pmd") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "PrW") = 0 _
                    Then
                    .Rows(lngZeile).Delete
                End If
            End If
        Next lngZeile
        For intSpalte = intLetzte To 8 Step -1
            If Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Pkt") = 0 _
                And Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Pmd") = 0 _
                And Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Prw") = 0 _
                Then
                .Columns(intSpalte).Delete
            End If
        Next intSpalte
    End With
    Application.ScreenUpdating = True
End Sub

Beachte, dass der Tabellenkopf keine Formeln mehr enthält sondern diese in Werte umgewandelt werden weil andernfalls dort Bezugsfehler auftreten, da ja Spalten gelöscht werden müssen und die Formeln keinen Bezug auf vorhergehende Spalten mehr nehmen können.

---

 

Danke Beverly. Ich bin allerdings erst am Donnerstag wieder an meinem Arbeitsrechner und kann es ausprobieren. Ich melde mich dann.

 

Es klappt ! Der Code macht genau, was ich wollte.
Ich freu mich :-)
Vielen vielen Dank !!!