VBA CODE Zellen nach bestimmten Textinhalt suchen und Zeile Färben?
Hallo, kann mir bitte jemanden mit dem Code behilflich sein?
Dieser Code sucht die Zellen in Spalte"A" nach bestimmten Textinhalt ab und bei Treffer löscht er die zughörige gesamte Zeile. Meine Frage: kann man diesen Code so ändern, dass anstatt die gefundene Zeile zu löschen nur mit einer Farbe z.B. Orange (44) färbt? Vielen Dank im Voraus.
Sub zeilenloeschen()
Dim i As Long
Dim letzteZeile As Long
Dim suchBereich As Range
Dim gefunden As Range
Dim ersterTreffer As String
Dim suchWert As String
suchWert = "1" 'hier kommt dein Suchwert rein
With ThisWorkbook.Sheets("Sheet4")
letzteZeile = .Range("A" & Rows.Count).End(xlUp).Row
Set suchBereich = .Range("A1:A" & letzteZeile)
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
If Not gefunden Is Nothing Then
ersterTreffer = gefunden.Address
Do
gefunden.Activate
ActiveCell.EntireRow.Delete shift:=xlUp
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
Loop While Not gefunden Is Nothing
End If
End With
End Sub
3 Antworten
Es müsst eigentlich reichen diese eine Zeile zu ändern:
Do
gefunden.Activate
ActiveCell.Interior.ColorIndex = 44
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart
Loop While Not gefunden Is Nothing
Bin aber nicht sicher. Teste einfach mal.
Sorry, ich bin da nicht mehr so fit drin. Schau mal, ob DAS hilft:
Do
gefunden.Activate
ActiveCell.Interior.ColorIndex = 44
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart).FindNext
Loop While Not gefunden Is Nothing
geht leider nicht aber trotzdem danke
Anscheinend findet die Schleife trotz FindNext weiter immer wieder den ersten Treffer im Suchbereich, wenn du also innerhalb der Schleife den Suchbereich verkleinerst funktioniert es, das kannst du erreichen wenn du die Do-Loopschleife
Do
gefunden.Activate
ActiveCell.EntireRow.Delete shift:=xlUp
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
Loop While Not gefunden Is Nothing
durch diese ersetzt
For n = 1 To letzteZeile
gefunden.Activate
ActiveCell.Interior.ColorIndex = 44
Set suchBereich = .Range("A" & n & ":A" & letzteZeile)
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
Next n
Wie hannes62a schon schrieb ist das aber auch per bedingter Formatierung lösbar (unter "Nur Zellen formatieren die enthalten" -> Bestimmter Text; mit Inhalt; Suchwert)
Vielen Dank für dein Tipp. Ich habe es getestet. Dein Code markiert nur die erste Ergebnis-Zelle danach macht er nicht weiter. Es markiert nur die Zelle, soll aber die ganze Zeile bis xlToRight markieren bzw. färben. Das Gute daran dass das Programm nicht mehr abstürzt.
Also mit der Zeile färben habe ich wie folgt gelöst:
Sub Farbe()
For i = 1 To 9999
If Cells(i, 1).Interior.ColorIndex = 50 Then
Rows(i).Range(Cells(1, 1), Cells(1, 1).End(xlToRight)).Interior.ColorIndex = 50
End If
Next i
End Sub
Es bleibt nur die weitersuchFunktion dass nicht funktioniert.
Ich hatte auch erst Zelle statt Zeile gelesen gehabt, daher beim Einfärben der Bezug auf die aktive Zelle mit
ActiveCell.Interior.ColorIndex =44
wenn man stattdessen
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 1).End(xlToRight)).Interior.ColorIndex = 44
nutzt wird die gesamte Zeile eingefärbt, aber bei mir findet er bereits alle Treffer :?
(Hab erst jetzt deine anderen beiden Kommentare gesehen)
Der Laufzeitfehler tritt auf da die Variable "gefunden" im ersten Durchlauf in dem keine Treffer im Bereich gefunden werden geleert wird und im nächsten Schleifendurchlauf versucht wird diese zu aktivieren. Also kann man diesen umgehen indem man die Schleife vorzeitig verlässt:
Sub zeilenfaerben()
Dim i As Long
Dim letzteZeile As Long
Dim suchBereich As Range
Dim gefunden As Range
Dim ersterTreffer As String
Dim suchWert As String
suchWert = "1" 'hier kommt dein Suchwert rein
With ThisWorkbook.Sheets("Sheet4")
letzteZeile = .Range("A" & Rows.Count).End(xlUp).Row
Set suchBereich = .Range("A1:A" & letzteZeile)
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
If Not gefunden Is Nothing Then
ersterTreffer = gefunden.Address
For n = 1 To letzteZeile
If gefunden Is Nothing Then
Exit For
End If
gefunden.Activate
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 1).End(xlToRight)).Interior.ColorIndex = 44
Set suchBereich = .Range("A" & n & ":A" & letzteZeile)
Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
Next n
End If
End With
End Sub
Die Zeile müsstest du anpassen
ActiveCell.EntireRow.Delete shift:=xlUp
Ich versuche das mal zu ergoogleln es geht nicht schwer
Range("A1").Interior.ColorIndex = 37
das kann ich für dich tun
Warum nutzt Du nicht einfach die Bedingte Formatierung?
Fürs Löschen ging das nicht, aber zum Einfärben ist das doch bestens geeignet.
Danke, die Bedingte Formatierung spricht leider nur Zellen bzw. Spalten.
Nein, das stimmt so nicht. Mit Bedingter Formatierung lassen sich auch ganze Zeilen einfärben, wenn beispielsweise in Spalte A ein bestimmter Wert steht.
Ich habe das eben so ausprobiert: Formelbasierte Bedingte Formatierung mit der Formel =$A1="Hallo"
Das Dollarzeichen ist wichtig. Vor der Spaltenangabe muss es stehen, vor der Zeile darf keines stehen. Sofern erfüllt, wunschgemäß einfärben.
Dann die Zelle kopieren, die gesamte Tabelle markieren (Quadrat oben links in der Ecke von Zeilen- und Spaltenköpfen), Inhalte Einfügen, Formate. Fertig. Jede Zeile, in der in Spalte A Hallo steht, wird jetzt eingefärbt. Das ist es doch, was Du wolltest, oder habe ich Dich falsch verstanden?
Das Ausdehnen auf die gesamte Tabelle geht sicher auch einfacher, aber ich mache es meistens so.
Der Clou ist das die in der Zelle nicht nur zb. "Hallo" steht sondern z.b. "Ich grüße Dich Hallo xyz". Das heißt kein eindeutiges Wert in der Zelle. Aber der obere Code funktioniert jetzt wie ich möchte. Besten Dank.
Auch das wäre kein Problem. Dann würde die Bedingung halt lauten:
=FINDEN("Hallo";$A1)<>0
Um unabhängig von Groß/Kleinschreibung zu werden, kann man das so ergänzen:
=FINDEN("HALLO";GROSS($A1))<>0
Vorteil ist, dass Du das einmal einrichtest und das in Zukunft auch für alle Änderungen automatisch funktioniert, ohne dass Du das Makro erneut anstoßen musst. Aber mach, wie es für Dich besser erscheint. Ich kenne ja den Hintergrund nicht.
Super! Danke für dein Tipp. Werde ich sicher für weiteres Vorhaben nutzen können:)
Danke für die Antwort. Der erste Treffer hat er gemacht aber nur A3 dann ist alles hängen geblieben, ich musste mit ESC abrechen.