Makro um doppelte Werte fablich zu hinterlegen

6 Antworten

Vom Fragesteller als hilfreich ausgezeichnet

Hier ein Code, der wechselseitig die gleichen Zellen färbt:

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim dblColorFlipFlop As Long

dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
            J = J + 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
    End If
Next I
End Sub

Achtung, bis Excel 2003 kann man bei RGB nur bestimmte Werte benutzen. Erst ab Excel 2010 ist alles möglich.

Statt 
 Interior.Color = RGB( …) kann man auch sagen 
 Interior.Colorindex  = 16

Ganzzahlig, von 1 bis 57  möglich.

Zum Ermitteln der möglichen Farben noch zwei Codes:

Sub srtFarbTest1()
Dim I As Integer
For I = 255 To 5 Step -1
    Cells(256 - I, 1) = I
    Cells(256 - I, 2).Interior.Color = RGB(I, I, I)
Next I
End Sub

Und Code drei

Sub srtFarbTest2()
Dim I As Integer
For I = 1 To 57
    Cells(I, 3) = I
    Cells(I, 4).Interior.ColorIndex = I
Next I

End Sub

Hoffe es hilft

So ganz, wie gewollt, funktioniert es noch nicht...
... sind mehr als 2 gleiche Einträge vorhanden, sind diese nicht mehr gleichfarbig.

Änderungvorschlag:
Beim FlipFlop schalten: Do While Cells(I + J) = Cells(I, 1)
die Spalte mit angeben: Do While Cells(I + J,1) = Cells(I, 1)

und

nach End With in neuer Zeile einfügen: I = I + J - 1
(damit wird der schon geprüfte und gefärbte Bereich übersprungen)

Gruß aus Berlin

0
@Britzcontrol

ACHTUNG: wenn letzte Zelle einen Doppeleintrag enthält, gibts einen Fehler.
Also die letzte Zelle nur mit Einzelwert testen.

0
@Britzcontrol

Hallo PauleVBA und Britzcontrol,

danke für eure Vorschläge, ich habe das jetzt mal so übernommen, wenn ich auf ausführen drücke, gibt mir Excel eine Fehlermeldung aus "Fehler beim Kompilieren If-Block ohne End If". Woran kann das liegen?

Ich habe versuch den Code mit Strg-K zu kopieren aber er wird hier immer nur als Text eingefügt.

0
@Excelfrager84

Das mit dem End If kann ich dir auch nicht erklären. Wenn du den obigen Code so übernommen hast, kann es diese Fehlermeldung nicht geben, es sei denn, du hast diesen Code in bereits bestehenden Code eingefügt.

  1. Anmelden
  2. den Code oben markieren
  3. Im VBA-Editor (Alt F11) einfach nur einfügen.

Und was den Code für das Board angeht:

  1. Code im VBA-Edirtor markieren und kopieren
  2. Kopiertes hier im Eingabefeld einfügen
  3. Diesen Text im Eingabefeld dann nochmals markieren
  4. jetzt Strg K drücken oder fünfte Schaltfläche über Textfeld anklicken
0
@PauleVBA

Hallo PauleVBA und Britzcontrol,

zusammen mit der Anmerkung von Britzcontrol funktioniert der Code von PauleVBA super, es ist jedoch so, dass immer nur zwei Zellen farblich hinterlegt werden, in meinem Dokument, kann es aber auch sein das es drei oder vier Zeilen farblich hinterlegt werden müssen. Kann man den Code so anpassen. Durch den Code werden ja auch nur die Zellen farblich hinterlegt, kann man das so erweitern, dass auch die ganze Zeile farblich hinterlegt wird, wie es mit den Code zur Bedingten Formatierung durchgeführt wurde?

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim dblColorFlipFlop As Long

dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("$A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J, 1) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
           I = I + J - 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
       
    End If
Next I
End Sub
0
@Excelfrager84

Nur mal schnell zu dem Vorhaben "ganze Zeile farblich zu hinterlegen".

Davon kann ich nur abraten, weil dann je "Färbung", also bis Spalte XFD, 16.384 Zellen formatiert sind. Das bläht alles auf.

Besser ist, den zu färbenden Bereich zu beschränken.

Gruß aus Berlin

0
@Britzcontrol

so, jetzt aber ...

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim n As Long
Dim dblColorFlipFlop As Long

n = 3 ' Anzahl der zu markierenden Spalten
dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("$A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J, 1) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
        J = J + 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, n)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, n)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
    I = I + J - 1
    End If
    
Next I
End Sub

Alle Anforderungen erfüllt ! (???)

Gruß aus Berlin

1

das machst du mit einem flip-flop: die beiden farbwerte legst du in ein array ab, mit dem index ff greifst du darauf zu (ff=1 oder 2). bei jeder zuteilung einer farbe schaltest du um: ff=3-ff .

@Maximilianus7: das mit dem Flip-Flop ist ja ganz nett, trifft aber nicht des Pudels Kern: 5 wäre hell, 6 dunkel, 7 hell usw. es soll aber 5 bis 7 hell und 8 bis dunkel werden.

0

Nicht genau wie von dir beschrieben, aber ähnlich kannst du es mit der bedingten Formatierung erreichen. Leg einfach zwei Regeln mit folgenden Formeln an:

  1. =UND(ODER(A2=A3;A2=A1);A2<>"")
  2. =UND(A2<>A1;A2=A3)

Der ersten Regel gibst du als Format eine Hintergrundfarbe, der 2. einen oberen Rahmen.

Beide Regeln werden angewendet auf =$A:$A.

Hallo Sapex22,

danke für deine Antwort, auf diesem Wege erhalte ich nicht das gewünschte Resultat. Es werde nur bestandeteile von Zeile grau hinterlegt, jedoch nicht die gesamte Zeile.

0
@Excelfrager84

Genau so hattest du aber deine Frage gestellt.
Naja, dann modifizierst du das Ganze halt:

=UND(ODER($A2=$A3;$A2=$A1);$A2<>"")
=UND($A2<>$A1;$A2=$A3)

und wendest die Regel an auf =$A:$X.

0

Wenn in einer Zelle eine bestimmtes Wort steht, sollen die Zeilen darunter ausgeblendet bzw. eingeblendet werden. Geht das?

Hi,

in der Spalte B2 steht entweder: Leer, Auto1 und Auto2

Jetzt möchte ich folgendes:

Auto 1 -> ausblenden der Zeilen A5 bis A1500. Auto 2 -> ausblenden der Zeilen A1501 bis A3000 Leer -> ausblenden der Zeilen A5 bis A3000

Geht sowas? Könnt Ihr mir helfen?

...zur Frage

Wie kann ich einen Variablen Empfänger im Makro integrieren?

Hallo,

ich habe bereits ein Makro, welches mir den Druckbereicht als PDF im Mail anhängt. Bei meinem Makro ist bisher aber ein fixer Empfänger hinterlegt.

Wie kann ich einen variablen Empfänger hinterlegen? Sprich: wenn in Zelle C3 "Abteilung 1" steht, dann soll Herr X die Mail bekommen; bzw. wenn in Zelle C3 "Abteilung 2" steht, dann soll Herr Y die Mail bekommen; usw. - In Zelle C3 ist ein Dropdown, welches sämtliche Abteilungen beinhaltet.

Die Mailadressen habe ich alle auf dem Tabellenblatt "EmailListe" hinterlegt. In Spalte B sind die Abteilungen untereinander, in Spalte C sind die Mailadressen An: und in Spalte E sind die Mailadressen CC:.

Vielen Dank für eure Hilfe!

...zur Frage

Excel Tabelle mit VBA fortlaufend befüllen?

Hallo,

ich habe eine ziemlich schwierige Aufgabe zu lösen, zumindest für mich als VBA Amateur und bräuchte deswegen eure Hilfe, da ich daran schon seit Tagen verzweifle.

Die Aufgabenstellung ist folgende:

Es soll durch ein Kontrollfenster (1. Bild links) möglich sein, einen neuen Datensatz anzulegen, der dann automatisch in der Tabelle (1. Bild rechts) davon erscheint. Die Erstellung der Datensätze soll fortlaufend geschehen, d.h. falls bereits ein Datensatz in Zeile 4 vorliegt, dass der neue Datensatz automatisch in Zeile 5 (usw.) angelegt wird. Zuletzt soll dann das Kontrollfenster geleert werden, sodass es theoretisch möglich wäre, direkt einen weiteren Datensatz anzulegen.

Weiterhin soll dieser neu angelegte Datensatz mit dem "DiagrammA" im Reiter "Diagramm" verknüpft werden (X/Y-Werte und Name in der Legende), sodass dort auch automatisch dieser Datensatz erscheint (2. & 3. Bild).

(Optional): Die Möglichkeit zum Entfernen eines Datensatzes.

Vielen Dank!

...zur Frage

Excel ausgewählte Zeilen drucken?

Hallo,

ich habe eine Excel Checkliste und möchte gerne per Makro all jene Zeilen Drucken, wo sich in der ersten Spalte ein Häckchen befindet.

Häckchen = 1

Des Weiteren brauche ich beim Ausdruck natürlich die Spaltenüberschrift, damit man auch weiß, für was jede Spalte gut ist.

Danke & lg

...zur Frage

Laufzeitfehler 429 in VBA (Excel Makro)?

Hallo!

Zurzeit versuche ich mich an VBA. Ich habe ein Makro erstellt, dass aus einer Excel Tabelle z.B. eine Rechnung erstellt ( durch befüllen der Texftfelder einer Vorlage )

Nun wollte ich das Makro so umändern, dass automatisch der richtige Pfad zum Speichern bzw Öffnen der Vorlage, für den jeweiligen Windows Nutzer benutzt wird. ( Das habe ich mithilfe von Workbook.Path gemacht.

Allerdings gibt er mir jetzt immer Laufzeitfehler 429 aus und ich weiß nicht was zu tun ist.

Bitte helft mir. ( Office und Word sind up to date )

Grüße

Chris

Hier mein Code: https://paste2.org/E8ZmvBXk

...zur Frage

VBA: Verschiedene Formel je Bedingung?

Ich sitze leider schon länger dran aber mittlerweile habe ich ein Brett vor dem Kopf.

Ich versuche meine Frage mal wie folgt zu beschreiben:

Wenn in Spalte P Ein Eintrag Namens "Hans" Vorhanden ist, so soll in Spalte AF eine Formel A hintelegt werden.
Bei anderen Einträgen in Spalte P wird Formel B hinterlegt.

Ich schaffe es, die Formel A einzutragen und sie Funktioniert auch, aber Formel B wird komplett ignoriert, obwohl in Spalte P andere Namens als Hans erscheinen.

'Dim Ende As Long
'ActiveSheet.UsedRange.AutoFilter Field:=16, Criteria1:="HANS"
'Range("AF2").FormulaLocal = "=WENN(HEUTE()-AE2<=40;""OK"";""P"")"
'Ende = Cells.SpecialCells(xlCellTypeLastCell).Row
'Range("AF2").AutoFill Destination:=Range("AF2:AF" & Ende), Type:=xlFillDefault

'ActiveSheet.UsedRange.AutoFilter Field:=16, Criteria1:="<>HANS"
'Range("AF2").FormulaLocal = "=WENN(HEUTE()-AE2<=30;""OK"";""P"")"
'Ende = Cells.SpecialCells(xlCellTypeLastCell).Row
'Range("AF2").AutoFill Destination:=Range("AF2:AF" & Ende), Type:=xlFillDefault

Vorab lieben Dank und

Viele Grüße

...zur Frage

Was möchtest Du wissen?