Makro korrigieren

Sub markiere_G20_G31() 'G20-G30 in blau+fett und G31-G99 rot+fett Sheets("WX").Select Dim lngSt As Long Dim rZelle As Range Dim strTemp As String Dim SuchWert As String For Each rZelle In Range("c3:c100") If rZelle "" Then With rZelle 'G20-G30 If InStr(.Value, "G") > 0 Then SuchWert = "G" Else SuchWert = "" If InStr(.Value, SuchWert) > 0 And SuchWert > "" Then strTemp = Right$(.Value, Len(.Value) - InStr(.Value, SuchWert) + 3) strTemp = Left$(strTemp, 2) If IsNumeric(strTemp) Then If strTemp >= 20 Then lngSt = InStr(.Value, strTemp & SuchWert) .Characters(start:=lngSt, Length:=Len(SuchWert & strTemp)).Font.ColorIndex = 5 .Characters(start:=lngSt, Length:=Len(SuchWert & strTemp)).Font.FontStyle = "Fett" End If End If End If 'G31-G99 If InStr(.Value, "G") > 0 Then SuchWert = "G" Else SuchWert = "" If InStr(.Value, SuchWert) > 0 And SuchWert > "" Then strTemp = Right$(.Value, Len(.Value) - InStr(.Value, SuchWert) + 3) strTemp = Left$(strTemp, 2) If IsNumeric(strTemp) Then If strTemp >= 31 Then lngSt = InStr(.Value, strTemp & SuchWert) .Characters(start:=lngSt, Length:=Len(SuchWert & strTemp)).Font.ColorIndex = 3 .Characters(start:=lngSt, Length:=Len(SuchWert & strTemp)).Font.FontStyle = "Fett" End If End If End If End With End If Next rZelle Range("A1").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub markiere_G20_G31() 'G20-G30 in blau+fett und G31-G99 rot+fett Sheets("WX").Select Dim lngPos As Long Dim rZelle As Range Application.ScreenUpdating = True For Each rZelle In Range("c3:c100") With rZelle If .Value "" And InStr(1, .Value, "G") > 0 Then 'Font zurücksetzen .Font.ColorIndex = xlColorIndexAutomatic 'schwarz .Font.Bold = False For lngPos = 1 To Len(.Value) 'Prüfen, ob "G" an Position If Mid(.Value, lngPos, 1) = "G" Then 'Text (2 Zeichen) links vom G prüfen If lngPos >= 3 Then If IsNumeric(Mid(.Value, lngPos - 2, 2)) Then 'Markierungsroutine aufrufen Call Markieren(Zelle:=rZelle, Wert:=Val(Mid(.Value, lngPos - 2, 2)), _ lngStart:=lngPos - 2) End If End If 'Text (2 Zeichen) rechts vom G prüfen If lngPos = 20 And Wert = 31 And Wert

Private Sub Markiere_KT20_KT31() 'KT20-KT30 in blau+fett und KT31-KT99 rot+fett Sheets("WX").Select Dim lngPos As Long Dim rZelle As Range Application.ScreenUpdating = True For Each rZelle In Range("c3:c100") With rZelle If .Value "" And InStr(1, .Value, "KT") > 0 Then ''''' 'Font zurücksetzen ''''' .Font.ColorIndex = xlColorIndexAutomatic 'schwarz ''''' .Font.Bold = False For lngPos = 1 To Len(.Value) 'Prüfen, ob "G" an Position If Mid(.Value, lngPos, 1) = "KT" Then 'Text (2 Zeichen) links vom G prüfen If lngPos >= 3 Then If IsNumeric(Mid(.Value, lngPos - 2, 2)) Then 'Markierungsroutine aufrufen Call Markieren(Zelle:=rZelle, Wert:=Val(Mid(.Value, lngPos - 2, 2)), _ lngStart:=lngPos - 2) End If End If ''''' 'Text (2 Zeichen) rechts vom G prüfen ''''' If lngPos

Sub Markieren(Zelle As Range, Wert As Double, lngStart As Long) 'Subroutine zum markieren der 3 Zeichen Dim Farbe As Long, Fett As Boolean 'Farbe(n) gemäß Wertebereich setzen 'KT20-KT30 in blau+fett und KT31-KT99 rot+fett If Wert >= 20 And Wert = 31 And Wert

Hallo,
versuche es mal so.
Für G

Sub Markieren()
Dim Bereich As Range
Dim objRegEx As Object, objMatch As Object
Dim i As Integer, iColor As Integer
Dim LRow As Long
Set objRegEx = CreateObject("VBScript.RegExp")

With objRegEx
 .IgnoreCase = False 'Groß u. Kleinschreibung nicht beachten, sonst False 
 .MultiLine = True
 .Global = True
 .Pattern = "[0-9]{2,2}[G]{1,1}|[G]{1,1}[0-9]{2,2}" 'Suchbegriffe durch | trennen 
End With

LRow = IIf(IsEmpty(Cells(100, 3)), Cells(100, 3).End(xlUp).Row, 100)
Set Bereich = Range("C3:C" & LRow) 'Suchbereich 

Application.ScreenUpdating = False
    With Bereich.Font
     .Bold = False
     .ColorIndex = xlAutomatic
    End With
    
    For Each Bereich In Bereich
     If Bereich <> "" Then
        
        Set objMatch = objRegEx.Execute(Bereich.Text)
        
        For i = 0 To objMatch.Count - 1
           With Bereich.Characters(objMatch(i).FirstIndex + 1, Len(objMatch(i)))
            
            Select Case Replace(objMatch(i), "G", "") * 1
             Case Is < "31": iColor = 5
             Case Is < "100": iColor = 3
             Case Else: iColor = xlAutomatic
            End Select
            
            .Font.ColorIndex = iColor
            .Font.Bold = True
           End With
        Next i
        
     
     End If
    Next Bereich

Application.ScreenUpdating = True
Set objMatch = Nothing: Set objRegEx = Nothing
End Sub

Für KT

Sub Markieren()
Dim Bereich As Range
Dim objRegEx As Object, objMatch As Object
Dim i As Integer, iColor As Integer
Dim LRow As Long
Set objRegEx = CreateObject("VBScript.RegExp")

With objRegEx
 .IgnoreCase = False 'Groß u. Kleinschreibung nicht beachten, sonst False 
 .MultiLine = True
 .Global = True
 .Pattern = "[0-9]{2,2}[KT]{2,2}|[KT]{2,2}[0-9]{2,2}" 'Suchbegriffe durch | trennen 
End With

LRow = IIf(IsEmpty(Cells(100, 3)), Cells(100, 3).End(xlUp).Row, 100)
Set Bereich = Range("C3:C" & LRow) 'Suchbereich 

Application.ScreenUpdating = False
    With Bereich.Font
     .Bold = False
     .ColorIndex = xlAutomatic
    End With
    
    For Each Bereich In Bereich
     If Bereich <> "" Then
        
        Set objMatch = objRegEx.Execute(Bereich.Text)
        
        For i = 0 To objMatch.Count - 1
           With Bereich.Characters(objMatch(i).FirstIndex + 1, Len(objMatch(i)))
            
            Select Case Replace(objMatch(i), "KT", "") * 1
             Case Is < "31": iColor = 5
             Case Is < "100": iColor = 3
             Case Else: iColor = xlAutomatic
            End Select
            
            .Font.ColorIndex = iColor
            .Font.Bold = True
           End With
        Next i
        
     
     End If
    Next Bereich

Application.ScreenUpdating = True
Set objMatch = Nothing: Set objRegEx = Nothing
End Sub

Gruß Tino

Private Sub Markiere_KT20_KT31() 'KT20-KT30 in blau+fett und KT31-KT99 rot+fett Dim rZelle As Range, strSuch As String Sheets("WX").Select Application.ScreenUpdating = True strSuch = "KT" For Each rZelle In Range("c3:c100") With rZelle If .Value "" And InStr(1, .Value, strSuch) > 0 Then .Font.Bold = False .Font.ColorIndex = xlColorIndexAutomatic Call Markiere_String_Nr_Links(rngZelle:=rZelle, SuchText:=strSuch, _ AnzZiffern:=2) ' Call Markiere_String_Nr_Rechts(rngZelle:=rZelle, SuchText:=strSuch, _ AnzZiffern:=2) End If End With Next rZelle Application.ScreenUpdating = False Range("A1").Select End Sub Sub Markiere_String_Nr_Links(rngZelle As Range, SuchText As String, _ AnzZiffern As Long) 'Sucht Text im Zellinhalt und markiert wenn Zahl links vom Text im Bereich Dim lngPos As Long Dim Farbe As Long, Fett As Boolean Dim Wert As Double, lngStart As Long, Anzahl As Long With rngZelle For lngPos = 1 To Len(.Value) 'Prüfen, ob Suchtext an Position If Mid(.Value, lngPos, Len(SuchText)) = SuchText Then If lngPos >= AnzZiffern + Len(SuchText) Then If IsNumeric(Mid(.Value, lngPos - AnzZiffern, AnzZiffern)) Then Wert = Val(Mid(.Value, lngPos - AnzZiffern, AnzZiffern)) lngStart = lngPos - AnzZiffern Anzahl = AnzZiffern + Len(SuchText) 'Farbe(n) gemäß Wertebereich setzen If Wert >= 20 And Wert = 31 And Wert = 20 And Wert = 31 And Wert

Sub Markieren() Dim Bereich As Range Dim objRegEx As Object, objMatch As Object Dim i As Integer, iColor As Integer Dim LRow As Long Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .IgnoreCase = False 'Groß u. Kleinschreibung nicht beachten, sonst False .MultiLine = True .Global = True .Pattern = "[0-9]{2,2}[G]|[G][0-9]{2,2}|[0-9]{2,2}[KT]{2,2}|[KT]{2,2}[0-9]{2,2}" 'Suchbegriffe durch | trennen End With LRow = IIf(IsEmpty(Cells(100, 3)), Cells(100, 3).End(xlUp).Row, 100) Set Bereich = Range("C3:C" & LRow) 'Suchbereich Application.ScreenUpdating = False With Bereich.Font .Bold = False .ColorIndex = xlAutomatic End With For Each Bereich In Bereich If Bereich <> "" Then Set objMatch = objRegEx.Execute(Bereich.Text) For i = 0 To objMatch.Count - 1 With Bereich.Characters(objMatch(i).FirstIndex + 1, Len(objMatch(i))) Select Case Replace(Replace(objMatch(i), "KT", ""), "G", "") * 1 Case Is < "31": iColor = 5 Case Is < "100": iColor = 3 Case Else: iColor = xlAutomatic End Select .Font.ColorIndex = iColor .Font.Bold = True End With Next i End If Next Bereich Application.ScreenUpdating = True Set objMatch = Nothing: Set objRegEx = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread