AW: Ziffernblöcke mit Einfärben
16.07.2008 07:24:00
Erich
Hi Claus,
probier mal
Sub ZiffernbloeckeUntereinander3()
Dim rng As Range, strE As String, lngZ As Long, intP As Integer
Dim strZ As String, strW As String
Dim arrI(1 To 10) As Integer, intI As Integer, intJ As Integer
Worksheets("Daten aus Word").Select
With Worksheets("Ziffernblöcke")
Range(.Columns(1), .Columns(2)).ClearContents
With .Columns(1)
.NumberFormat = "@"
.Font.ColorIndex = 0
End With
lngZ = 1
For Each rng In Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
strW = rng
strE = ""
For intP = 1 To Len(strW)
strZ = Mid(strW, intP, 1)
If intP " " And _
Not Mid(strW, intP + 1, 1) Like "[0-9]" And _
Mid(strW, intP + 1, 1) = Mid(strW, intP + 2, 1) And _
Mid(strW, intP + 3, 1) Like "[0-9]" Then
strE = strE & strZ & "00" & Mid(strW, intP + 3, 1)
intP = intP + 3
intI = intI + 1
arrI(intI) = Len(strE) - 2
ElseIf strZ Like "[0-9]" Then
strE = strE & strZ
ElseIf strE > "" Then
With .Cells(lngZ, 1)
.Value = strE
For intJ = 1 To intI
.Characters(arrI(intJ), 2).Font.ColorIndex = 3
Next intJ
End With
intI = 0
.Cells(lngZ, 2) = rng.Address(0, 0)
strE = ""
lngZ = lngZ + 1
End If
Next intP
If strE > "" Then
With .Cells(lngZ, 1)
.Value = strE
For intJ = 1 To intI
.Characters(arrI(intJ), 2).Font.ColorIndex = 3
Next intJ
End With
intI = 0
.Cells(lngZ, 2) = rng.Address(0, 0)
lngZ = lngZ + 1
End If
Next rng
.Select
End With
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort