Autoform als Ampel (VBA Code optimieren)

[M.Wichmann]

Hallo,

ich möchte für ein Projekt gerne Autoformen als Ampel und Schaltfläche nutzen.

Ich habe das auch alles soweit hinbekommen, allerdings reagiert die Farbumschaltung nur, wenn ich in der entsprechenden Zelle die Zahl manuell eingebe. Was müßte ich ändern, das die Umschaltung auch auf eine Änderung der Zelle durch Berechnung funktioniert?

Hier der Code:

Code:

Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)
   If Target = Range("A21") Then    'Wert steht in A1
       ActiveSheet.Shapes("Rechteck 4").Select    'Rechteck 4 ist der Name der Freihandform
       With Selection
           .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
       End With
       Target.Select
   End If
' Hier für eine weitere Form
   If Target = Range("A22") Then    'Wert steht in A2
       ActiveSheet.Shapes("Rechteck 5").Select    'Freeform 2 ist der Name der Freihandform
       With Selection
           .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
       End With
       Target.Select
   End If
   If Target = Range("A23") Then    'Wert steht in A2
       ActiveSheet.Shapes("Rechteck 6").Select    'Freeform 2 ist der Name der Freihandform
       With Selection
           .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
       End With
       Target.Select
   End If
End Sub

Private Function fctFarbe(dblWert As Double) As Byte
   Select Case dblWert
   Case Is >= 5        'Werte und Relationen anpassen
       fctFarbe = 10   'Farbwerte entsprechend ändern
   Case Is >= 4
       fctFarbe = 11
   Case Is >= 2
       fctFarbe = 5
   Case Else
       fctFarbe = 9
   End Select
End Function

[shift-del]

Hallo

Vielleicht Worksheet_Calculate() statt Worksheet_Change()?

[RPP63]

Moin!
Nur schon mal vorsorglich:
Das _Calculate() hat keine Übergabeparameter.

Gruß Ralf

[M.Wichmann]

Hallo, ich habe diesen Code im Netz gefunden, und an meine datei angepasst.

Das habe ich schon probiert. Aber dann kommt es zu einem Fehler(Variable nicht definiert)

Oder gibt es evtl sogar eine einfachere Möglichkeit das Umzusetzen?

Ich benötige Momentan 3 Varianten, um den Code so nutzen zu können dachte ich an die Formellösung in der Tabelle.

1. Variante:   Datum > Heute = grün, Datum < Heute = Rot
2. Variante:  zusätzlich Datum < Heute +5 = Gelb
3. Variante:  Datum < Heute +20 = Gelb

[RPP63]

Nur schon mal vorsorglich:
Das _Calculate() hat keine Übergabeparameter.

Das habe ich schon probiert. Aber dann kommt es zu einem Fehler(Variable nicht definiert)

Ich erkenne aber an, dass Du kurz nach meinem Beitrag gepostet hast.
Wahrscheinlich hast Du ihn noch nicht gelesen.

Gruß Ralf

[M.Wichmann]

Hallo Ralf, ja das hatte ich erst später gesehn. 
Aber probiert hatte ich es schon bevor ich diesen Beitrag hier eröffnet habe.

Ich probiere bei Problemen immer erst mir selbst zu helfen, aber komme trotz Google nicht wirklich weiter.

[Steffl]

Hallo Mario,

ist ungetestet

Code:

Private Sub Worksheet_Calculate()
  
    If Cells(1, 1) = Range("A21") Then   'Wert steht in A1
'        ActiveSheet.Shapes("Rechteck 4").Select    'Rechteck 4 ist der Name der Freihandform
        With ActiveSheet.Shapes("Rechteck 4")
            .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
        End With
    End If
' Hier für eine weitere Form
    If Cells(2, 1) = Range("A22") Then   'Wert steht in A2
'        ActiveSheet.Shapes("Rechteck 5").Select    'Freeform 2 ist der Name der Freihandform
        With ActiveSheet.Shapes("Rechteck 5")
            .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
        End With
    End If
    If Cells(2, 1) = Range("A23") Then   'Wert steht in A2
'        ActiveSheet.Shapes("Rechteck 6").Select    'Freeform 2 ist der Name der Freihandform
        With ActiveSheet.Shapes("Rechteck 6")
            .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
        End With
    End If
    
End Sub

[M.Wichmann]

Hallo Stefan,


leider klappt das nicht, auch der Fehler, variable nicht definiert.

[Steffl]

Hallo,

Code:

Private Sub Worksheet_Calculate()
  
    If Cells(1, 1) = Range("A21") Then   'Wert steht in A1
'        ActiveSheet.Shapes("Rechteck 4").Select    'Rechteck 4 ist der Name der Freihandform
        With ActiveSheet.Shapes("Rechteck 4")
            .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Cells(1, 1).Value)
        End With
    End If
' Hier für eine weitere Form
    If Cells(2, 1) = Range("A22") Then   'Wert steht in A2
'        ActiveSheet.Shapes("Rechteck 5").Select    'Freeform 2 ist der Name der Freihandform
        With ActiveSheet.Shapes("Rechteck 5")
            .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Cells(2, 1).Value)
        End With
    End If
    If Cells(2, 1) = Range("A23") Then   'Wert steht in A2
'        ActiveSheet.Shapes("Rechteck 6").Select    'Freeform 2 ist der Name der Freihandform
        With ActiveSheet.Shapes("Rechteck 6")
            .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Cells(2, 1).Value)
        End With
    End If
    
End Sub

[RPP63]

Ja, da steht ja auch noch Target drin!
Ebenfalls ungetestet (heißt, Du könntest mal etwas zum Testen hochladen!):

Private Sub Worksheet_Calculate()
    Me.Shapes("Rechteck 4").Select    'Rechteck 4 ist der Name der Freihandform 
    With Selection
        .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Me.Range("A21"))
    End With
    ' Hier für eine weitere Form 
    ActiveSheet.Shapes("Rechteck 5").Select    'Freeform 2 ist der Name der Freihandform 
    With Selection
        .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Me.Range("A22"))
    End With
    ActiveSheet.Shapes("Rechteck 6").Select    'Freeform 2 ist der Name der Freihandform 
    With Selection
        .ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Me.Range("A23"))
    End With
End Sub

Gruß Ralf