Makro ändert gegen meinen Willen die Schriftfarbe
17.03.2018 15:35:23
Christian
vielleicht hat jemand von euch ja eine Idee und die Ahnung von Makros um bei meinem Problem zu helfen.
Ich markiere den Bereich E2:E18221, kopiere ihn und füge ihn an der selben Stelle ein.
Ziel ist es, dass unten stehendes Makro ausgeführt wird.
In diesem Bereich sind 37 Texte mit roter Schrifarbe versehen.
Das Makro scheint die Schriftfarbe aus E2 (schwarz) zu übernehmen. Ich hätte aber gerne, dass das was rot ist auch rot bleibt.
Es betrifft nur spalte E, die anderen Spalten, die in dem Makro invlviert sind, behalten ihre Schriftfarbe.
Hat da jemand eine Lösung? Vor allem ohne dass das Ausführen des Makros (derzeit 7 Minuten) sich nochmal merklich in die Länge zieht?
Viele Grüße
Christian
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TC As Long
Dim c As Range
Application.ScreenUpdating = False
If Target.Columns.Count > 1 Then Exit Sub
If Target.Column = 5 Or Target.Column = 7 Then TC = Target.Column Else Exit Sub
'If Target.Count = 1 And Target "" Then
On Error GoTo ERREXIT
Application.EnableEvents = False
Select Case TC
Case 5: For Each c In Target
If c "" Then Call SpalteE(c)
Next
Case 7: For Each c In Target
If c "" Then
Call SpalteG(c)
Call SpalteE(c)
End If
Next
End Select
ERREXIT:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub SpalteG(ByVal Target As Range)
Dim r As Range, c As Range, z&, cc As Range, zf&
Dim gefunden As Boolean
If Target.Offset(, -6) "" Then
z = Target.Row
gefunden = False
Set cc = Range("A1:A" & z - 1).Find(Target.Offset(, -6).Value, _
Range("A1"), xlValues, xlWhole)
If Not cc Is Nothing Then
zf = cc.Row
Do
Set cc = Range("A1:A" & z - 1).FindNext(cc)
If cc.Offset(, 6) = Target Then
Target.Offset(, -2) = cc.Offset(, 4) '& " " & (cc.Offset(, 4).Address)
gefunden = True
End If
Loop Until cc Is Nothing Or cc.Row = zf Or gefunden
End If
If Not gefunden Then Target.Offset(, -2).Value = "n.v."
End If
End Sub
Sub SpalteE(ByVal Target As Range)
Dim lngR As Long
lngR = Target.Row
Cells(lngR, 2).FormulaR1C1 = Cells(1, 2).FormulaR1C1
Cells(lngR, 3).FormulaR1C1 = Cells(1, 3).FormulaR1C1
Cells(lngR, 6).FormulaR1C1 = Cells(1, 6).FormulaR1C1
Cells(lngR, 8).FormulaR1C1 = Cells(1, 8).FormulaR1C1
Cells(lngR, 9).FormulaR1C1 = Cells(1, 9).FormulaR1C1
Cells(lngR, 10).FormulaR1C1 = Cells(1, 10).FormulaR1C1
Cells(lngR, 11).FormulaR1C1 = Cells(1, 11).FormulaR1C1
Cells(lngR, 12).FormulaR1C1 = Cells(1, 12).FormulaR1C1
Rows(lngR).Copy
Cells(lngR, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Target.Select
End Sub