Codefehler
WalterK
mit Hilfe verschiedener Anfragen habe ich folgenden Code zusammen gestellt. Allerdings läuft er nicht so wie er sollte. Eigentlich funktioniert nur Punkt 1, den Rest habe ich vermutlich falsch zusammen gesetzt.
Die Idee ist folgende:
1.) Suche in Zeile 2 die Überschrift BEZEICHNUNG. Wenn die Überschrift BEZEICHNUNG vorhanden ist, gehe zu 2, ansonsten soll der Code mit der MsgBox abbrechen.
2.) Prüfe, ob in der Spalte BEZEICHNUNG mindestens 1mal eine Hintergrundfarbe vorhanden ist. Wenn mindesten 1 Hintergrundfarbe vorhanden ist, gehe zu 3, ansonsten soll der Code mit der MsgBox abbrechen.
3.) Formatiere alle Zellen mit den gleichen Texten mit der gleichen manuell vergebenen Hintergrundfarbe.
4.) Formatier die Spalten JÄNNER bis DEZEMBER mit der in der Spalte BEZEICHNUNG vergebenen Hintergrundfarbe.
Hier noch der Code: Option Explicit Sub LK_einfärben() Dim rngBezeich As Range Dim Zelle As Range Dim myDic As Object Set myDic = CreateObject("scripting.Dictionary") Dim Rng As Range, MyBool As Boolean, lngBezeich As Long, lngrow As Long, lngBeginn As Long, _ lngEnde As Long With ActiveSheet On Error GoTo ErrExit Application.ScreenUpdating = False lngrow = Cells(Rows.Count, 3).End(xlUp).Row lngBezeich = Application.Match("BEZEICHNUNG", Rows(2), 0) lngBeginn = Application.Match("JÄNNER", Rows(2), 0) lngEnde = Application.Match("DEZEMBER", Rows(2), 0) Set rngBezeich = Intersect(.Range("A2").CurrentRegion, .Rows(2).Find("BEZEICHNUNG"). _ EntireColumn) For Each Rng In Range(Cells(3, lngBezeich), Cells(lngrow, lngBezeich)) If Rng.Interior.ColorIndex xlNone Then MyBool = True Next If MyBool Then GoTo ErrExit For Each Zelle In rngBezeich If Not myDic.exists(Zelle.Value) Then myDic(Zelle.Value) = Zelle.Interior.Color Else: Zelle.Interior.Color = myDic(Zelle.Value) End If Next For lngrow = 3 To Cells(Rows.Count, lngBezeich).End(xlUp).Row Range(Cells(lngrow, lngBeginn), Cells(lngrow, lngEnde)).Interior.ColorIndex _ = Cells(lngrow, lngBezeich).Interior.ColorIndex Next End With ErrExit: If Err.Number 0 Then MsgBox "FEHLER: Das Makro wurde vorzeitig beendet, weil entweder: " & vbCr & "" & vbCr & " _ 1.) in Zeile 2 die Überschrift BEZEICHNUNG fehlt oder " & vbCr & "" & vbCr & " 2.) in der Spalte darunter nicht mindestens eine (1) Zelle farblich hinterlegt ist!" ', vbCritical End If Set myDic = Nothing Set rngBezeich = Nothing End Sub
https://www.herber.de/bbs/user/78764.xls
Besten Dank für die Hilfe, Servus Walter