AW: VBA Zellen einfärben
26.07.2012 23:32:38
fcs
Hallo Walter,
so sollte es funktionieren.
Gruß
Franz
Sub LK_einfärben()
'Teil 1 - sucht die Spalte Bezeichnung und färbt Zellen mit identischem Text gleich ein,
'falls für diesen Text manuell eine Farbe hinterlegt wurde.
'Es soll eine MsgBox erscheinen, wenn die Überschrift BEZEICHNUNG fehlt oder überhaupt
'keine Zelle in der Spalte BEZEICHNUNG manuell farblich hinterlegt wurde.
Dim rngBezeich As Range
Dim Zelle As Range
Dim myDic As Object
Set myDic = CreateObject("scripting.Dictionary")
Dim MyBool As Boolean, varBezeich As Variant, varBeginn As Variant, varEnde As Variant
On Error GoTo ErrHandler:
With ActiveSheet
varBezeich = Application.Match("BEZEICHNUNG", .Rows(2), 0)
varBeginn = Application.Match("JÄNNER", .Rows(2), 0)
varEnde = Application.Match("DEZEMBER", .Rows(2), 0)
If IsError(varBezeich) Then
MsgBox "Spalte ""BEZEICHUNG"" nicht vorhanden", _
vbInformation, "Makro: LK_einfärben"
GoTo ErrHandler
End If
Application.ScreenUpdating = False
Set rngBezeich = Intersect(.Range("A2").CurrentRegion, _
.Rows(2).Find("BEZEICHNUNG").EntireColumn)
'gefärbte Zellen ermitteln
For Each Zelle In rngBezeich
If Zelle.Interior.ColorIndex xlColorIndexNone Then
If Not myDic.exists(Zelle.Value) Then
myDic(Zelle.Value) = Zelle.Interior.Color
MyBool = True
End If
End If
Next
If MyBool = False Then
MsgBox "In Spalte ""BEZEICHNUNG"" sind keine Zellen eingefärbt", _
vbInformation, "Makro: LK_einfärben"
GoTo ErrHandler
End If
'Zellen gleicher Bezeichung und Bereich JÄNNER bis DEZEMBER einfärben
For Each Zelle In rngBezeich
If myDic.exists(Zelle.Value) Then
'***Teil 1 - Zellen in Spalte "BEZEICHNUNG" färben
Zelle.Interior.Color = myDic(Zelle.Value)
'***Teil 2 - färbt die Spalten von JÄNNER bis DEZEMBER ein.
If Not (IsError(varBeginn) Or IsError(varEnde)) Then
.Range(.Cells(Zelle.Row, varBeginn), .Cells(Zelle.Row, varEnde)).Interior.Color _
= myDic(Zelle.Value)
End If
End If
Next
End With
If IsError(varBeginn) Or IsError(varEnde) Then
MsgBox "In Zeile 2 fehlt die Überschrift JÄNNER oder DEZEMBER!", _
vbInformation, "Makro: LK_einfärben"
End If
ErrHandler:
If Err.Number 0 Then
MsgBox "Sonstiger Fehler-Nr.: " & Err.Number & vbCr _
& Err.Description, vbCritical, "Makro: LK_einfärben"
End If
Application.ScreenUpdating = True
End Sub