String markieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Markiere_2_oder_3_oder_4_Schraegstriche() Dim lngSt As Long ' Dim rZelle As Range ' Dim strTemp As String ' Dim SuchWert As String ' For Each rZelle In Range("c1:c200") If rZelle "" Then With rZelle 'suche: // If InStr(.Value, "//") > 0 Then SuchWert = "//" 'suche: /// ElseIf InStr(.Value, "///") > 0 Then: SuchWert = "///" 'suche: //// ElseIf InStr(.Value, "////") > 0 Then: SuchWert = "////" Else SuchWert = "" End If If InStr(.Value, SuchWert) > 0 And SuchWert > "" Then strTemp = Right$(.Value, Len(.Value) - InStr(.Value, SuchWert) + 0) strTemp = Left$(strTemp, Len(SuchWert)) lngSt = InStr(.Value, SuchWert) .Characters(start:=lngSt, Length:=Len(SuchWert & strTemp)).Font.ColorIndex = 3 .Characters(start:=lngSt, Length:=Len(SuchWert & strTemp)).Font.FontStyle = "Fett" End If End With End If Next rZelle End Sub

Sub Markieren() Dim Bereich As Range Set Bereich = Range("C1:C200") Application.ScreenUpdating = False With Bereich.Font .Bold = False .ColorIndex = xlNone End With For Each Bereich In Bereich If Bereich <> "" And Bereich Like "*////*" Then With Bereich.Characters(InStr(Bereich, "////"), 4) .Font.ColorIndex = 3 .Font.Bold = True End With End If Next Bereich Application.ScreenUpdating = True End Sub

Sub Markieren() Dim Bereich As Range Dim objRegEx As Object, objMatch As Object Dim i As Integer Dim LRow As Long Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .MultiLine = True .Global = True .Pattern = "////" End With LRow = IIf(IsEmpty(Cells(200, 3)), Cells(200, 3).End(xlUp).Row, 200) Set Bereich = Range("C1: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, 4) .Font.ColorIndex = 3 .Font.Bold = True End With Next i End If Next Bereich Application.ScreenUpdating = True Set objMatch = Nothing: Set objRegEx = Nothing End Sub

Sub Markieren() Dim Bereich As Range Dim objRegEx As Object, objMatch As Object Dim i As Integer Dim LRow As Long Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .IgnoreCase = True 'Groß u. Kleinschreibung nicht beachten, sonst False .MultiLine = True .Global = True .Pattern = "////|Tino|Mehmet|Herber" 'Suchbegriffe durch | trennen End With LRow = IIf(IsEmpty(Cells(200, 3)), Cells(200, 3).End(xlUp).Row, 200) Set Bereich = Range("C1: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))) .Font.ColorIndex = 3 .Font.Bold = True End With Next i End If Next Bereich Application.ScreenUpdating = True Set objMatch = Nothing: Set objRegEx = Nothing End Sub

Hallo Tino,
warum klappt es diesmal nicht:


Private Sub Markiere_BR_SN_FG_TS_etc()
Sheets("WX").Select
Dim Bereich As Range
Dim objRegEx As Object, objMatch As Object
Dim i As Integer
Dim LRow As Long
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.IgnoreCase = True 'Groß u. Kleinschreibung nicht beachten, sonst False
.MultiLine = True
.Global = True
.Pattern = " BR | HZ | VA | FU | GR | RA | DZ | PR | SH | BC | VC | MI | SN | SG | IC | PL |  _
GR | VU | DU | SA | PO | SQ | FC | SS | DS | FZ | FG | TS |+|-" 'Suchbegriffe durch | trennen
End With
LRow = IIf(IsEmpty(Cells(200, 3)), Cells(200, 3).End(xlUp).Row, 200)
Set Bereich = Range("C1: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)))
.Font.ColorIndex = 3
.Font.Bold = True
End With
Next i
End If
Next Bereich
'Application.ScreenUpdating = True
Set objMatch = Nothing: Set objRegEx = Nothing
Range("A1").Select
End Sub

Ich bekomme
Laufzeitfehler '5018':
Anwendungs- oder objektdefinierter Fehler.
Vorher hat es doch geklappt!
Gruss
mehmet

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