AW: Zeichen links und Rechts des Suchtextes lösche
24.07.2006 19:17:12
fcs
Hallo Gregor,
habe mich auch mit deiner Frage beschäftigt und bin beim Testen über all die beschriebenen Probleme gestolpert. Es bleibt nichts anderes über, als zunächst in einer Schleife die Positionen der Klammerpaare zu ermitteln und in einer Feld-Variablen zu speichern.
In einer 2. Schleife werden dann die Textteile fett formatiert.
Sub Fett_Schrift()
' Formatiert Textteiel die in Klammern stehn FETT und löscht Klammern
Dim intStart As Integer, intEnde As Integer, I As Integer
Dim rng As Range, arrPos() As Integer
Anzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
' For Each rng In Range("d1:e100" & Anzahl)' ======Alt======
For Each rng In Range("d1:e" & Anzahl) ' ======Korrektur======
If Len(rng) > 0 Then
ReDim arrPos(1 To 10, 1 To 2)
intStart = InStr(1, rng, "(")
intEnde = InStr(1, rng, ")")
If intStart > 0 And intEnde > 0 Then
'Ermittlung der Position von Klammerpaaren
I = 1
Do
arrPos(I, 1) = intStart
arrPos(I, 2) = intEnde - 1
' Klammern ersetzen durch nichts
rng = Application.WorksheetFunction.Replace(rng.Value, intStart, 1, "")
rng = Application.WorksheetFunction.Replace(rng.Value, intEnde - 1, 1, "")
intStart = InStr(intEnde - 1, rng, "(")
intEnde = InStr(intEnde - 1, rng, ")")
I = I + 1
Loop While intStart > 0 And intEnde > 0
'Textteile entsprechend ermitelter Positionen Fett formatieren
For I = 1 To UBound(arrPos, 1)
If arrPos(I, 1) = 0 Then Exit For
rng.Characters(arrPos(I, 1), arrPos(I, 2) - arrPos(I, 1)).Font.Bold = True
Next
End If
End If
Next
ReDim arrPos(1, 1)
End Sub
gruss Franz