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 !!!

 

Hi,
ich habe den Code an einer größeren Beispieltabelle getestet und versucht, ihn auf 5 unterschiedliche Kurse zu erweitern. Das Ergebnis hat mich etwas überrascht. In der im Anhang hochgeladenen Tabelle werden z.B. die Gruppe 17 und der 03.01.2021 fälschlich angezeigt, obwohl dort keine Kurse 1-5 stattfinden. Dafür wurde die Zeilen der Gruppen 5 - 9 gelöscht, obwohl sie Kurse enthalten.
Habe ich da was vermurkst und man kann den Code nicht einfach so erweitern?

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)), "Kurs 1") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "Kurs 2") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "Kurs 3") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "Kurs 4") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 8), .Cells(lngZeile, intLetzte)), "Kurs 5") = 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)), "Kurs 1") = 0 _
                And Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 2") = 0 _
                And Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 3") = 0 _
                And Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 4") = 0 _
                And Application.CountIf(.Range(.Cells(6, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 5") = 0 _
                Then
                .Columns(intSpalte).Delete
            End If
        Next intSpalte
    End With
    Application.ScreenUpdating = True
End Sub

LG

 

Hi,

wenn du einen anderen Tabellenaufbau hast, musst du die Startspalten und -zeilen natürlich anpassen:

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, 1), .Cells(lngLetzte, intLetzte)).Copy
        .Range("A1").PasteSpecial Paste:=xlValues
        For lngZeile = lngLetzte To 2 Step -1
            If .Cells(lngZeile, 1) <> "" Then
                If Application.CountIf(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, intLetzte)), "Kurs 1") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, intLetzte)), "Kurs 2") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, intLetzte)), "Kurs 3") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, intLetzte)), "Kurs 4") = 0 _
                    And Application.CountIf(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, intLetzte)), "Kurs 5") = 0 _
                    Then
                    .Rows(lngZeile).EntireRow.Delete
                End If
            End If
        Next lngZeile
        For intSpalte = intLetzte To 2 Step -1
            If Application.CountIf(.Range(.Cells(2, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 1") = 0 _
                And Application.CountIf(.Range(.Cells(2, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 2") = 0 _
                And Application.CountIf(.Range(.Cells(2, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 3") = 0 _
                And Application.CountIf(.Range(.Cells(2, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 4") = 0 _
                And Application.CountIf(.Range(.Cells(2, intSpalte), .Cells(lngLetzte, intSpalte)), "Kurs 5") = 0 _
                Then
                .Columns(intSpalte).EntireColumn.Delete
            End If
        Next intSpalte
    End With
    Application.ScreenUpdating = True
End Sub

---

 

@Beverly : Sry, dass ich mich erst jetzt melde, ich konnte mich erst heute wieder der Excel-Problematik zuwenden :-)

Ich hatte diese Testtabelle am Montag erzeugt, weil ich versuchen wollte herauszufinden, warum dein Code vom 12.12.2021 für mich nur teilweise funktioniert. Ich habe alles Mögliche rumprobiert, aber mir fehlt irgend wie das tiefere Verständnis für VBA ;-)

Folgendes funktioniert in meiner große Tabelle nicht:
Wenn ich das Makro starte, werden nur die relevanten Spalten gelöscht, nicht aber die Zeilen.

Ich habe mal eine bereinigte Fassung meiner großen Tabelle hier angehängt. Das Makro ist schon eingefügt, das Ergebnis nach dem Ausführen ist auf dem 2. Blatt. Die für mich relevanten Zellen (mit den Inhalten Pkt, Pdm oder PrW) sind rot unterlegt. Man kann sehen, dass auf Blatt 2 alle Spalten gelöscht wurden, die keine rot markierten Zellen haben. Die 398 Zeilen sind aber alle noch da, obwohl gerade im unteren Bereich viele Zeilen keine relevanten Inhalte haben.

Ich weiß nicht mehr weiter ...

 

Hi,

deine ursprünglich hochgeladene Mappe implizierte, dass nur die Zeilen bearbeitet werden sollen, in denen in Spalte B (2) ein Inhalt vorhanden ist - das berücksichtigt dieser Codeteil:

Code:

        For lngZeile = lngLetzte To 6 Step -1
            If .Cells(lngZeile, 2) <> "" Then '<== Zeile weglassen
                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 '<== Zeile weglassen
        Next lngZeile

Bei deiner jetzigen Mappe ist das nicht mehr der Fall. Lasse also die beiden markierten Zeilen weg, dann wird dies nicht mehr überprüft und generell alle Zeilen durchlaufen.

---

 

es .... geht .....
Tausend Dank !