AW: verschiedene Farbformate in einer Zelle
29.03.2007 22:00:16
Uduuh
Hallo,
nette Aufgabe. Mal was abseits vom Standard.
Sub Replace_mit_Farben()
Dim rngFind As Range, rngFirst As Range
Dim strFind As String, strReplace As String
Dim intFind As Integer, intReplace As Integer
Dim vntColors(), intX As Integer, intCounter As Integer
strFind = "innen" 'anpassen
strReplace = "aussen" 'anpassen
intFind = Len(strFind)
intReplace = Len(strReplace)
Set rngFind = Cells.Find(What:=strFind, After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not rngFind Is Nothing Then
Set rngFirst = rngFind
Do
Set rngFind = Cells.FindNext(After:=rngFind)
'Farben merken
intX = InStr(rngFind, strFind)
ReDim vntColors _
(1 To WorksheetFunction.Max(Len(rngFind), Len(rngFind) - strFind + strReplace))
For intCounter = 1 To intX - 1
vntColors(intCounter) = rngFind.Characters(intCounter, 1).Font.ColorIndex
Next intCounter
For intCounter = intX To intX + intReplace - 1
vntColors(intCounter) = 3
Next intCounter
For intCounter = intX + intReplace To UBound(vntColors)
vntColors(intCounter) = _
rngFind.Characters(intCounter + intFind - intReplace, 1).Font.ColorIndex
Next intCounter
'ersetzen
rngFind = Replace(rngFind, strFind, strReplace)
'Farben schreiben
For intCounter = 1 To UBound(vntColors)
rngFind.Characters(intCounter, 1).Font.ColorIndex = vntColors(intCounter)
Next intCounter
Loop Until rngFind.Address = rngFirst.Address
End If
End Sub
Gruß ausm Pott
Udo