Zellen prüfen und entsprechend einfärben
28.01.2022 11:34:17
Paul
ich möchte in 2 Worksheets Zellen gegeneinander prüfen und bei Übereinstimmung in Worksheet "Übersicht" die Zelle + 2 Zeilen weiter unten in der Farbe einfärben, die in Worksheet "Farbvergabe" neben der Projektnummer NEU bzw. ALT festgelegt wurde.
Leider bekomme ich den Fehler: "Laufzeitfehler '1004': Anwendungs oder objektdefinierter Fehler" ausgegeben und finde nicht die Lösung dafür.
Vielen Dank schonmal im Vorraus für jede Hilfe.
Der Code:
Option Compare Text
Option Explicit
Sub Einfaerben()
Dim datax As Range
Dim range_data As Range
Dim FarbReiheZähler As Integer
Dim Farbvergabe As Excel.Worksheet
Dim Übersicht As Excel.Worksheet
Set Farbvergabe = Worksheets("Farbvergabe")
Set Übersicht = Worksheets("Übersicht")
Set range_data = Übersicht.Range("F7:ON149")
FarbReiheZähler = 2
'***alle Zellen Abfragen
For Each datax In range_data
'***zuerst auf Projektnummer NEU prüfen und ggf. einfärben
If datax.Value = Farbvergabe.Range(Farbvergabe.Cells(FarbReiheZähler, 1)).Value Then
Farbvergabe.Range(Farbvergabe.Cells(FarbReiheZähler, 3)).Copy
Übersicht.Range(Übersicht.Cells(datax.Row, datax.Column), Übersicht.Cells(FarbReiheZähler + 2, datax.Column)).PasteSpecial xlPasteFormats
FarbReiheZähler = FarbReiheZähler + 1
'***auf Projektnummer ALT prüfen und ggf. einfärben
If datax.Value = Farbvergabe.Range(Farbvergabe.Cells(FarbReiheZähler, 2)) Then
Farbvergabe.Range(Cells(FarbReiheZähler, 3)).Copy
Übersicht.Range(Übersicht.Cells(datax.Row, datax.Column), Übersicht.Cells(FarbReiheZähler + 2, datax.Column)).PasteSpecial xlPasteFormats
FarbReiheZähler = FarbReiheZähler + 1
End If
End If
Next datax
Application.CalculateFull
End Sub