Auch Zelle Links und Rechts einfärben.
18.09.2020 12:08:40
Albin
Brauche mal wieder Eure Hilfe, komme einfach nicht weiter. Das Marko läuft eigentlich
schön durch und führt das gewünscht auch durch. Mir fehlt einfach noch die Option, dass
auch die Zelle A und C, in der gefunden Zeile eingefärbt wird. Wie auch der Text Links und Rechts in Fett
daher kommt, so wie in Spalte B.
Wäre schön, wenn jemand von Euch Zeit hätte.
Danke und Gruss
Albin
https://www.herber.de/bbs/user/140311.xlsm
Sub Textfett()
Dim vFormArr As Variant
Dim vLgArr As Variant
Dim iAnz As Integer
Dim c As Range
Dim firstAddress
vFormArr = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "A", "B", "C", "D", "E" _
_
, "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", _
"Y", "Z")
vLgArr = Array(6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, _
_
27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 36, 37, 38, 39, 40, 41, 42, 43)
For iAnz = 0 To UBound(vFormArr)
With Worksheets("Register").Range("B1:B2500")
Set c = .Find(vFormArr(iAnz), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Cells(c.Row, 2).Characters(Start:=1, Length:=vLgArr(iAnz)).Font ' Bei Problemen _
hier, Anzahl Oben "30, 31, 32, 33, 34) erweiterm
.FontStyle = "Fett"
c.Interior.ColorIndex = 39
.Size = 12
'firstAddress = IIf(ActiveCell.Row = 1, 0, -1)
'c.Row.ActiveCell.Offset(-1, 0)
''c = ActiveCell.Offset(0, 1)
' c.Interior.ColorIndex = 39
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address firstAddress
End If
End With
Next iAnz
End Sub