AW: Farben in Formen über Tabelle anpassen
09.04.2014 10:43:20
fcs
Hallo Lemmi,
das erfordert dann ein entsprechendes Ereignismakro, das auf Eingaben in Zellen reagiert.
Außerdem muss die geänderte Gruppe dann jeweils in den sichtbaren Bereich gescrollt werden.
Bitte beacte die Hinweise, wo die jeweiligen Makros in der Datei angelegt werden müssen.
Gruß
Franz
'Code unter dem Tabellenmodul der Tabelle mit den sich ändernden Zellen
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zeile As Long, rngRow As Range
With Target
Select Case .Column
Case 4 To 12 'Spalten D bis L
'geänderte Zeilen abarbeiten
For Each rngRow In Target.Rows
Zeile = rngRow.Row
Select Case Zeile
Case 8 To 27 'Zeilenbereich mit Werten zu feldgrupen
'prüfen, ob GruppeName eingetragen und Farbwerte für alle 9 Felder eingetragen
If Cells(Zeile, 3) "" And _
Application.WorksheetFunction.Count(Range(Cells(Zeile, 4), _
Cells(Zeile, 12))) = 9 Then
Call prcGruppeFaerben(strGrpName:=Cells(Zeile, 3).Text, _
rngFarben:=Range(Cells(Zeile, 4), Cells(Zeile, 12)))
Application.ScreenUpdating = True
If MsgBox("zurück zur aktiven Zelle", _
vbQuestion + vbYesNo, _
"Anzeige Gruppe: " & Cells(Zeile, 3).Text) = vbYes Then
ActiveCell.Select
ActiveWindow.ScrollColumn = 1
End If
End If
Case Else
'do nothing
End Select
Next rngRow
Case Else
'do nothing
End Select
End With
End Sub
'Code in einem allgemeinen Modul oder im gleichen Modul wie obiges Ereignismakro
Sub prcGruppeFaerben(strGrpName As String, rngFarben As Range)
Dim objGruppe As Shape, objShape As Shape, intI
On Error GoTo Fehler
Set objGruppe = rngFarben.Parent.Shapes(strGrpName)
'Gruppe in den sichtbaren Bereich scrollen
ActiveWindow.ScrollRow = objGruppe.TopLeftCell.Row '### neu!!
ActiveWindow.ScrollColumn = objGruppe.TopLeftCell.Column '### neu!!
For intI = 0 To 8
Set objShape = objGruppe.GroupItems("Feld_" & Format(intI, "00"))
Select Case rngFarben.Cells(1, intI + 1)
Case 0
objShape.Fill.Visible = False
Case 1
objShape.Fill.Visible = True
objShape.Fill.ForeColor.RGB = RGB(0, 176, 80) 'dunkel grün
Case 2
objShape.Fill.Visible = True
objShape.Fill.ForeColor.RGB = RGB(255, 255, 0) 'gelb
Case 3
objShape.Fill.Visible = True
objShape.Fill.ForeColor.RGB = RGB(255, 0, 0) 'rot
End Select
Next intI
Fehler:
With Err
Select Case .Number
Case 0 'do nothing
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf _
& "Gruppen-Name Shape: " & strGrpName & vbLf _
& " oder " & vbLf _
& "Gruppenelement: Feld_" & intI
End Select
End With
End Sub