AW: VBA Zellen im Bereich formatieren
01.02.2017 00:29:08
Piet
Hallo Blue Bird
anbei ein in deinem Beispiel getesteter Makro Code der die Aufgabe lösen sollte. Einfach in ein neues Modul kopieren und testen. Damit du den zu prüfenden Text leichter aendern kannst sind 5 Texte als Const festgelgt. Kleine Besonderheit sind die QTexte 4+5. Da gibt es in Originaltext einen Seitenumbruch. Ich habe sie als QText deklariert, weil ich die Texte als Teil-Strings prüfen muss.
mfg Piet
Option Explicit '31.1.2017 Piet Herber Forum
'1. finde den Eintrag (X)
'2. suche max. 5 Zellen weiter oben nach den Texten "LPH4" oder "LPH5", wenn gefunden farbig _
ausfüllen
'3. suche max. 4 Zellen weiter oben nach den Texten "Prüfung" oder "Freigabe", wenn gefunden _
farbig ausfüllen
'4. suche max. 4 Zellen weiter links nach den Texten "Bewehrungspläne", "Fertigteil- & _
Einbauteilpläne", "Positionspläne", "Schalpläne" oder "Stahlbau Übersichtspläne", wenn gefunden farbig ausfüllen
Const Txt1 = "Bewehrungspläne"
Const Txt2 = "Positionspläne" '
Const Txt3 = "Schalpläne"
Const QTxt4 = "Fertigteil- & Einbauteilpläne"
Const QTxt5 = "Stahlbau Übersichtspläne"
Const Farbe = 10
Sub Farblich_markieren()
Dim AC As Object, j, Txt As String
Dim QTxt As String, LTxt As String
Sheets("Tabelle1").Select
'alte Innenfarbe löschen
ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
'Schleife für UsedRange nach "X" durchsuchen
For Each AC In ActiveSheet.UsedRange
If AC.Value = "X" Then
AC.Interior.ColorIndex = Farbe
'suche nach oben nach Text oder "LPHxx"
For j = 1 To 20
If AC.Offset(-j, 0).RowHeight Empty Or LTxt Empty Then
'suche ganzes Wort "Prüfung" oder "Freigabe"
If Txt = "Prüfung" Or Txt = "Freigabe" Then
AC.Offset(-j, 0).Interior.ColorIndex = Farbe
End If
'suche Text "LPHxx" in String
If InStr(Txt, "LPH 4") Or InStr(Txt, "LPH 5") Or _
InStr(Txt, "LPH4") Or InStr(Txt, "LPH5") Then
AC.Offset(-j, 0).Interior.ColorIndex = Farbe
End If
'suche L-Text "LPHxx" in Left String (Verundzelle)
If InStr(LTxt, "LPH 4") Or InStr(LTxt, "LPH 5") Or _
InStr(LTxt, "LPH4") Or InStr(LTxt, "LPH5") Then
AC.Offset(-j, -1).Interior.ColorIndex = Farbe
End If
End If
Next j
'suche nach links mehrere Texte (Pläne)
For j = 1 To 4
If AC.Offset(0, -j).ColumnWidth Empty Then
If Txt = Txt1 Or Txt = Txt2 Or Txt = Txt3 Then
AC.Offset(0, -j).Interior.ColorIndex = Farbe
Else
'Pläne mit Space und LF im Text
If Left(Txt, 8) = Left(QTxt4, 8) And _
Right(Txt, 12) = Right(QTxt4, 12) Then
AC.Offset(0, -j).Interior.ColorIndex = Farbe
End If
If Left(Txt, 8) = Left(QTxt5, 8) And _
Right(Txt, 12) = Right(QTxt5, 12) Then
AC.Offset(0, -j).Interior.ColorIndex = Farbe
End If
End If
End If
If AC.Offset(0, -j).Column = 2 Then Exit For
Next j
End If
Next AC
End Sub