Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.04.2024 20:05:21
CreateObject auf MacOS
28.04.2024 18:33:31
Excel Fenster fixieren
28.04.2024 18:25:12
Excel Aufbauende Summe
28.04.2024 14:18:05
Einfügen ohne Select
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1932to1936
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1932to1936
1932to1936
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Gleicher Inhalt

Gleicher Inhalt
02.07.2023 18:47:13
Marc

Hallo liebes Forum,
ich benötige eure Hilfe.

Sollzustand: Auf Tabellenblatt "Auswahl" soll Spalte Üb3 im Listobject "Übersicht" immer Aufsteigend sortiert sein.
Ist in Üb3 ein Eintrag mit gleichem Inhalt untereinander zb.1010/1010 sollen die Zeilen im listobject "Übersicht"
dunkelblau markiert werden.
Wenn darunter zb.2x 2020 steht sollen die Zeilen hellblau markiert werden.
Steht nun 1x 1030 drin soll wieder hellblau markiert werden.
Immer im Wechsel, wenn sich der Inhalt ändert.
So soll auf den ersten Blick erkannt werden hier beginnt ein neuer anderer Inhalt als zuvor in Spalte Üb3.
Die Zahlen 1010/1020 usw. sind nur Beispielhaft.
Das ganze soll auch noch funktionieren wenn Üb1/Üb2 oder und Üb3 gefiltert oder die Einträge verändert werden.

Lösungen Bitte in VBA
Danke schonmal

24
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Gleicher Inhalt
02.07.2023 18:51:51
onur
Und du glaubst ernsthaft, dass jemand dir einen Code schreibt (schreiben kann), wenn er die Datei dazu gar nicht kennt?
Ausserdem ist das Forum dafür gedacht, Leuten bei kleineren Problemen zu helfen und nicht für kostenlose Auftragsprogrammierung.


AW: Gleicher Inhalt
02.07.2023 19:52:59
Marc
Danke Onur für deine schnelle Antwort.

Auf dem Bild sieht man nochmal deutlicher was gemeint ist.
Mehr als das Listobject "Übersicht" auf dem Blatt Auswahl gibt es nicht.
Und es ist auch keinerlei Code vorhanden.
Dieses wunderbare Forum hab ich schon mehrmals besucht und mir wurde immer freundlich begegnet und geholfen.

Des weiteren bin ich oft erstaunt was für komplizierte Sachen hier behandelt werden. Da fällt es schwer zu folgen.
Von daher ist meine Bitte nach Hilfe bestimmt weit von einer Auftragsprogrammierung entfernt.

Evtl. gibt es auch diesmal jemanden der mir gerne Helfen möchte.

MFG Marc


Anzeige
AW: Gleicher Inhalt
02.07.2023 19:54:40
onur
Aber was soll man mit einem Bild? Anhand dessen deine Datei nachbauen ???


AW: Gleicher Inhalt
02.07.2023 19:58:01
onur
Wenn du massgefertigte Schuhe willst, braucht der Schuster auch deine Füße und nicht ein Bild davon.


AW: Gleicher Inhalt
02.07.2023 19:58:56
onur
Aber nur, wenn es dir nicht zu viele Umstände bereitet...


AW: Gleicher Inhalt
02.07.2023 20:05:58
onur
Geht doch.


AW: Gleicher Inhalt
02.07.2023 20:50:56
onur
Hier die Lösung als Bild:
Userbild


Anzeige
AW: Gleicher Inhalt
02.07.2023 21:51:03
Marc
Da hast du recht.
Danke für deine Lösung!!

Funktioniert erstmal gut!
Nach ein bisschen austesten ist mir aufgefallen das in bestimmten Filter Einstellungen
nicht korrekt farblich hinterlegt wird.
Lade die Datei mit der Filtereinstellung gleich hoch.

Evtl. kann das noch behoben werden.
Und Danke nochmals Onur

MFG Marc


AW: Gleicher Inhalt
03.07.2023 00:38:36
Ulf 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim bVorher As Boolean
    bVorher = Application.EnableEvents
    Application.EnableEvents = False
    färben
    Application.EnableEvents = bVorher
End Sub

Public Sub färben()
    On Local Error GoTo färbenERR
    Dim lObj As ListObject
    Dim lngZähler As Long
    Dim lngBis As Long
    Dim rRange As Range
    Dim lngA As Long, lngB As Long
    Dim hell As Long, dunkel As Long
    Dim bBool As Boolean
    hell = RGB(152, 245, 255)
    dunkel = RGB(135, 206, 250)
    bBool = False
    Set lObj = ActiveWorkbook.Worksheets("Auswahl").ListObjects("Übersicht")
    Set rRange = lObj.Range
    lngBis = rRange.Rows.Count
    lngZähler = 2
    Do Until lngZähler = lngBis
        lngA = rRange(lngZähler, 3).Value
        lngB = rRange(lngZähler + 1, 3).Value
        If lngA = lngB Then
            Do Until rRange(lngZähler, 3).Value > lngB And lngZähler = lngBis
                rRange.Rows(lngZähler).Interior.Color = IIf(bBool, hell, dunkel)
                lngZähler = lngZähler + 1
            Loop
            bBool = Not bBool
            rRange.Rows(lngZähler).Interior.Color = IIf(bBool, hell, dunkel)
        Else
            rRange.Rows(lngZähler).Interior.Color = IIf(bBool, hell, dunkel)
            lngZähler = lngZähler + 1
            bBool = Not bBool
        End If
        If lngZähler = lngBis Then
            lngA = rRange(lngZähler, 3).Value
            lngB = rRange(lngZähler - 1, 3).Value
            If lngA = lngB Then
                rRange.Rows(lngZähler).Interior.Color = rRange.Rows(lngZähler - 1).Interior.Color
            Else
                rRange.Rows(lngZähler).Interior.Color = IIf(bBool, hell, dunkel)
            End If
        End If
    Loop
färbenERR:
    Set rRange = Nothing
    Set lObj = Nothing
    Exit Sub
End Sub


Anzeige
AW: Gleicher Inhalt
04.07.2023 08:53:12
Marc
Danke Ulf auch für deine Lösung.
Funktioniert auch soweit aber bei manchen Filter Einstellungen wird falsch farblich hinterlegt.
Und als ich bei Üb3 auf Absteigen sortieren geklickt habe wurde auf einmal alles unterhalb des listobjects bis ans Ende des Blattes blau hinterlegt.

@Onur,möchte auf Formeln verzichten (Hilfsspalten Wahr/Falsch).
MFG Marc


AW: Gleicher Inhalt
04.07.2023 14:01:49
onur
Was für Hilfspalten denn? Ich habe doch gar keine !
Wenn du die Formel in A1 meinen solltest: Es gibt keine Möglichkeit (kein Event) für VBA, festzustellen, ob gerade gefiltert wurde oder nicht, weil sich dadurch ja nix ändert, ausser der Ansicht. Ohne die Formel müsstest du das Makro nach jedem Filtern per Button manuell ausführen.


Anzeige
AW: Gleicher Inhalt
05.07.2023 17:57:12
onur
WAS für ein Fehler genau denn? Ich habe keine gehabt.
Was genau hast du gemacht?


AW: Gleicher Inhalt
05.07.2023 18:27:04
Marc
Die Meldung kam als ich in Üb1 gefiltert habe, danach nicht mehr.
Wenn in Üb3 absteigend sortiert wird oder in Üb2 „E2“ rausgenommen wird (in der jetzig abgespeicherten Konstellation) , kommt die Meldung auch.
Wenn die Meldung nicht kommt passt die Farbhinterlegung leider trotzdem nicht.

Datei Gleicher Inhalt Fehler Sortieren:
https://www.herber.de/bbs/user/159816.xlsm


Anzeige
AW: Gleicher Inhalt
05.07.2023 18:30:09
onur
Aber was soll die händische Sortiererei? Das wird doch automatisch gemacht.
DU hast doch geschrieben: "Auf Tabellenblatt "Auswahl" soll Spalte Üb3 im Listobject "Übersicht" immer Aufsteigend sortiert sein"


AW: Gleicher Inhalt
05.07.2023 18:47:35
Marc
Das ist richtig. Ist beim ausprobieren aufgefallen.
Es sollte ein Vorsortieren sein was immer beim öffnen der Mappe geschieht mit der Möglichkeit auch mal händisch absteigend zu sortieren. Da habe ich mich ungenau ausgedrückt.
Das heißt, das Automatische sortieren verträgt sich nicht mit dem Händischen, dann müsste der Code also rausgenommen werden.

Würde dann die Farbhinterlegung mit der Formel Funktionieren?


Anzeige
AW: Gleicher Inhalt
04.07.2023 19:03:31
Ulf 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim bVorher As Boolean
    Dim filterRangeNoHeaders As Range
    Set filterRangeNoHeaders = Range("B5:D5")
    If Not (Target.ListObject Is Nothing) Then
        bVorher = Application.EnableEvents
        Application.EnableEvents = False
        färben
        Application.EnableEvents = bVorher
        Exit Sub
    End If
    If VarType(Target.Value) > 8204 Then
        Exit Sub
    End If
    If Target(1, 1) > "Üb1" Then
        Exit Sub
    End If
    If Not Application.Intersect(filterRangeNoHeaders, Target) Is Nothing Then
        bVorher = Application.EnableEvents
        Application.EnableEvents = False
        färben
        Application.EnableEvents = bVorher
    End If
    Exit Sub
End Sub


Option Explicit

Public Sub färben()
    On Local Error GoTo färbenERR
    Dim lObj As ListObject
    Dim lRows As ListRows
    Dim lRow As ListRow
    Dim lngA As Long, lngB As Long
    Dim lngX As Long, lngY As Long
    Dim hell As Long, dunkel As Long
    Dim col As New Collection
    Dim bBool As Boolean
    Dim lngZähler As Long
    Dim lngBis As Long
    Dim rRange As Range
    hell = RGB(152, 245, 255)
    dunkel = RGB(135, 206, 250)
    bBool = False
    Set lObj = ActiveWorkbook.Worksheets("Auswahl").ListObjects("Übersicht")
    For Each lRow In lObj.ListRows
        If Not lRow.Range.EntireRow.Hidden Then
            col.Add lRow.Index
        End If
    Next lRow
    lngBis = col.Count
    lngZähler = 1
    Do Until lngZähler = lngBis
        lngA = lObj.ListRows(col.Item(lngZähler)).Range(3).Value
        lngB = lObj.ListRows(col.Item(lngZähler + 1)).Range(3).Value
        If lngA = lngB Then
            If lngZähler >= lngBis Then
                Exit Sub
            End If
            Do Until lObj.ListRows(col.Item(lngZähler)).Range(3).Value > lngB And lngZähler = lngBis
                lObj.ListRows(col.Item(lngZähler)).Range.Interior.Color = IIf(bBool, hell, dunkel)
                lngZähler = lngZähler + 1
            Loop
            bBool = Not bBool
            lObj.ListRows(col.Item(lngZähler)).Range.Interior.Color = IIf(bBool, hell, dunkel)
        Else
            If lngZähler >= lngBis Then
                Exit Sub
            End If
            lObj.ListRows(col.Item(lngZähler)).Range.Interior.Color = IIf(bBool, hell, dunkel)
            lngZähler = lngZähler + 1
            bBool = Not bBool
        End If
        If lngZähler = lngBis Then
            lngA = lObj.ListRows(col.Item(lngZähler)).Range(3).Value
            lngB = lObj.ListRows(col.Item(lngZähler - 1)).Range(3).Value
            If lngA = lngB Then
                lObj.ListRows(col.Item(lngZähler)).Range.Interior.Color = lObj.ListRows(col.Item(lngZähler - 1)).Range.Interior.Color
            Else
                lObj.ListRows(col.Item(lngZähler)).Range.Interior.Color = IIf(bBool, hell, dunkel) 'rRange.Rows(lngZähler).Interior.Color = IIf(bBool, hell, dunkel)
            End If
        End If
    Loop
färbenERR:
    Set lObj = Nothing
End Sub
Nach einzel-selektierer Auswahl kann es nötig sein (habe keine Logik gefunden, wird mit Cache/Vermeidung Neuberechnung zusammenhängen) , in die Überschrift zu klicken. Alternativ die Bedingungen von onur mit zelle schaffen.
hth
Ulf


Anzeige
AW: Gleicher Inhalt
05.07.2023 17:50:48
Marc
Muss mich erst nochmal bei euch Bedanken, das ihr bei der Sache am Ball bleibt!

@ Ulf, wenn in die Tabelle geklickt wird konnte ich bis jetzt noch keinen Fehler festellen.
Es wird alles farblich richtig hinterlegt.

Ist es eigentlich möglich das Set filterRangeNoHeaders = Range("B5:D5") statt B5:D5 das Listobject direkt angesprochen wird?
Angenommen es kommt eine Spalte hinzu dann würde der Bereich nicht mehr stimmen und müsste Händisch angepasst werden.

Hier die gleiche Frage, kann man den Spaltennamen anstatt der 3 verwenden bei
lngA = lObj.ListRows(col.Item(lngZähler)).Range(3).Value
Wird die Spalte verschoben käme es wohl zu einer Fehlermeldung.
(Wird der Name der Spalte verändert funktioniert es natürlich auch nicht mehr)
Aber würde mich mal Interessieren.

Habe versucht das Ganze zu automatisieren, mit der Formel von Onur.

Private Sub Worksheet_Change(ByVal Target As Range)
Call färben
End Sub
Es wurde aber erst richtig Farblich hinterlegt als ich wieder in die Tabelle geklickt habe.
Wie kann man die Formel einbauen das die Farbhinterlegung Automatisch ausgelöst wird?

@Onur, dachte es läuft darauf hinaus das ich die Formel runterkopieren muss (Hilfsspalte).
Deine Lösung mit der Formel ist gut.
Es kommt allerdings immer eine Fehlermeldung beim Sortieren.

MFG Marc

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige