AW: (Teil-)Textlängen u.-Positionen b.Zusammen ...
18.12.2014 07:39:53
Mullit
Hallo Heinz,
da kamen mir irgendwie zwei Möglichkeiten in den Sinn, vielleicht ist was dabei.....
Option Explicit
Public Sub test()
Dim lngIndex As Long, lngCount As Long, _
lngColor As Long, lngSearchPos As Long, _
lngLength As Long, lngRow As Long
Application.ScreenUpdating = False
With Cells(9, 8) '"H9"
.ClearContents
For lngRow = 9 To 18
.Value = Cells(lngRow + 1, 2).Value & "; " & Cells(lngRow + 1, 3).Value & "; " & Chr(10) & .Value
Next
lngIndex = 1
lngCount = 1
Do
Select Case lngCount
Case Is = 1: lngColor = vbBlue
Case Is = 2: lngColor = vbCyan
Case Is = 3: lngColor = vbGreen
Case Is = 4: lngColor = vbMagenta
Case Is = 5: lngColor = vbRed
Case Is = 6: lngColor = vbBlack
End Select
lngSearchPos = InStr(lngIndex, .Text, ";", vbTextCompare)
If lngSearchPos <> 0 Then
lngLength = lngSearchPos
If lngCount = 6 Then
lngCount = 1
Else
lngCount = lngCount + 1
End If
Else
lngLength = .Characters.Count
End If
.Characters(Start:=lngIndex, Length:=lngLength).Font.Color = lngColor
lngIndex = lngSearchPos + 1
Loop While lngIndex < .Characters.Count And lngSearchPos <> 0
End With
Application.ScreenUpdating = True
End Sub
Public Sub test2()
Dim lngIndex As Long, lngCount As Long, _
lngColor As Long, lngRow As Long
Dim avntArray As Variant
Dim vntElem As Variant
Application.ScreenUpdating = False
With Cells(9, 8) '"H9"
.ClearContents
For lngRow = 9 To 18
.Value = Cells(lngRow + 1, 2).Value & "; " & Cells(lngRow + 1, 3).Value & "; " & Chr(10) & .Value
Next
avntArray = Split(Expression:=.Text, Delimiter:="; ", Compare:=vbTextCompare)
lngIndex = 1
lngCount = 1
For Each vntElem In avntArray
If vntElem = Chr(10) Then Exit For
Select Case lngCount
Case Is = 1: lngColor = vbBlue
Case Is = 2: lngColor = vbCyan
Case Is = 3: lngColor = vbGreen
Case Is = 4: lngColor = vbMagenta
Case Is = 5: lngColor = vbRed
Case Is = 6: lngColor = vbBlack
End Select
If lngCount = 6 Then
lngCount = 1
Else
lngCount = lngCount + 1
End If
.Characters(Start:=InStr(lngIndex, .Text, vntElem, vbTextCompare), _
Length:=Len(vntElem) + 1).Font.Color = lngColor
lngIndex = Len(vntElem) + 2
Next
End With
Application.ScreenUpdating = True
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
Gruß, Mullit