Case Select SPEZIALE

Hello friends,
ich weiss ja, so kurz vor'm Fest habt ihr besseres zu tun, als nach VBA-Blondinen und ihren Problemchen Ausschau zu halten, ich wage es trotzdem:
Habe ein Sheet mit etlichen Spalten und einigen Tausend Datensätzen. Bestimmte Spalten möchte ich bedingt formatieren: da mehr als 3 Bedingungen via VBA bzw. Case select...
Mein Problem: ich möchte bei Erfüllen der Bedingung(en) NICHT den ganzen Zellinhalt (Strings, btw!) mit dem gewählten Format bestücken, sondern eben nur den gesuchten bzw. gefundenen TEILSTRING. Also zB. steht in Zelle A1: strenger Abholer, in A45768: angestrengtes Nachdenken und in A65134: wurde strenguliert aufgefunden. (Tippfehler, soll trotzdem gefunden werden!) Die Länge der Zell-Inhalte ist also ganz unterschiedlich, ich möchte aber nur (via CASE SELECT ?), daß das Suchwort streng/STRENG in Farbe Rot/fett formatiert wird, NICHT der komplette Zellinhalt. In der gleichen Spalte A sollen auch alle Teilstrings lautend auf kein ebenfalls in Farbe Rot/fett formatiert werden und außerdem alle Teilstrings lautend auf nie. Aber wie gesagt: nicht die ganze Zelle, sondern eben nur der jeweilige Fund. Pro Spalte habe ich ca. 20 Such-Teilstrings (Bedingungen?), die immer in gleicher Weise hervorgehoben werden sollen, also nicht etwa streng in ROT/FETT und nie in BLAU/FETT, eben alle Fundstellen (nur in der betreffenden Spalte!) in ROT/FETT. In der Spalte B will ich genauso vorgehen, da habe ich allerdings andere Suchbegriffe; auch hier sollen die Teil-Strings ROT/FETT formatiert werden, sobald eine Zelle dieser Spalte den gesuchten Teil-String enthält... Könnt ihr mir helfen? Würd mich freuen, weil die Case Select-Anweisung zwar derzeit gut funktioniert, aber bei 20 Bedingungen irgendwie nicht wirklich hilfreich ist, wenn eben die GANZE ZELLE immer formatiert wird...
Da seh ich vor lauter Rot-Schrift nimmer, was eigentlich der Such-String war... Allen, die mir helfen wollen: lieben Dank vorab...
Und an wirklich alle: www wünsche wunderbares weihnachtsfest! grüsse, n

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub format() Dim lz&, gef As Range, a%, e%, Adr1$, i% lz = Cells(Rows.Count, 10).End(xlUp).Row For i = 1 To lz Set gef = Columns("A:A").Find(Cells(i, 10).Value, LookAt:=xlPart, MatchCase:=False) If Not gef Is Nothing Then a = InStr(gef.Value, Cells(i, 10).Value) e = Len(Cells(i, 10).Value) With gef.Characters(Start:=a, Length:=e).Font .Name = "Arial" .FontStyle = "Fett" .ColorIndex = 3 End With Adr1 = gef.Address End If Do Set gef = Columns("A:A").FindNext(After:=gef) If Not gef Is Nothing Then a = InStr(gef.Value, Cells(i, 10).Value) e = Len(Cells(i, 10).Value) With gef.Characters(Start:=a, Length:=e).Font .Name = "Arial" .FontStyle = "Fett" .ColorIndex = 3 End With End If Loop While Not gef.Address = Adr1 Next i End Sub

Hallo Nies (gesundheit)
als Ansatz.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub TeilstringMarkieren()
Dim a As Variant, b As Variant
Dim intFirstC As Integer, intLastC As Integer
Dim l As Integer, m As Integer, n As Integer, x As Integer
Dim lngFirstR As Long, lngLastR As Long, lngI As Long

lngFirstR = 1 'erste Zeile die Überprüft werden soll

intFirstC = 1 'erste Spalte die Überprüft werden soll
intLastC = 2 'letzte Spalte die Überprüft werden soll

Redim b(intLastC - intFirstC)

b(0) = Array("streng", "nach") 'Wörter die in der ersten Spalte markiert werden sollen
b(1) = Array("nie", "erfolg", "vers") 'Wörter die in der zweiten Spalte markiert werden sollen
'...

For l = intFirstC To intLastC

    lngLastR = Application.Max(lngFirstR, Cells(Rows.Count, l).End(xlUp).Row)

    With Range(Cells(lngFirstR, l), Cells(lngLastR, l))
        .Font.Bold = False
        .Font.ColorIndex = xlAutomatic
    End With

    a = Range(Cells(lngFirstR, l), Cells(lngLastR, l))

    For lngI = 1 To UBound(a, 1)
        n = 1
        For m = 0 To UBound(b(l - intFirstC))
            n = 1
            Do
                x = InStr(n, LCase(a(lngI, 1)), LCase(b(l - intFirstC)(m)))
                If x > 0 Then
                    Cells(lngI + lngFirstR - 1, l).Characters(x, Len(b(l - intFirstC)(m))).Font.ColorIndex = 3
                    Cells(lngI + lngFirstR - 1, l).Characters(x, Len(b(l - intFirstC)(m))).Font.Bold = True
                    n = x + 1
                Else
                    Exit Do
                End If
            Loop While n < Len(a(lngI, 1))
        Next
    Next
Next

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread