Clever-Excel-Forum

Seiten: 1 2 3

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

Hallo

Vielleicht Worksheet_Calculate() statt Worksheet_Change()?

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

Gruß Ralf

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

(05.07.2017, 10:57)RPP63 schrieb: [ -> ]Nur schon mal vorsorglich:
Das _Calculate() hat keine Übergabeparameter.

M.Wichmann schrieb: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

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.

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

Hallo Stefan,

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

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

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

Seiten: 1 2 3

M.Wichmann

shift-del

RPP63

M.Wichmann

RPP63

M.Wichmann

Steffl

M.Wichmann

Steffl

RPP63