Formen ausfüllen, wenn..

[brooker]

Hallo,

ich möchte gerne vorhandene Formen automatisch füllen lassen, wenn in einer Zelle ein bestimmter Wert eingegeben wird.
Im Anhang dazu die Beispiel-Datei.

Wenn ich die "3" ändere und z.B. eine 5 eintrage, sollen alle Sterne ausgefüllt sein. Wenn ich eine "1" eintrage, natürlich nur ein Stern. Der Rahmen/Linie um die anderen Sterne soll aber sichtbar bleiben.
Es kann auch vorkommen, dass ich einen Wert wie z.B. 3,55 eintrage. Dann der Stern halb gefüllt sein.

Ist das via VBA möglich? 

Die Zelle mit dem Wert wird händisch eingeben und nicht per Formel ausgelesen.

Danke für eure Hilfe.
Brooker

[RPP63]

Moin!
Was hältst Du hiervon (Spalte B Schriftart Wingdings):

Tabelle2

	A	B
1	3	«««
2	5	«««««
3	2	««
4	4	««««

Formeln der Tabelle

Zelle Formel B1 =WIEDERHOLEN(ZEICHEN(171);A1) B2 =WIEDERHOLEN(ZEICHEN(171);A2) B3 =WIEDERHOLEN(ZEICHEN(171);A3) B4 =WIEDERHOLEN(ZEICHEN(171);A4)

 

Gruß Ralf

[brooker]

Hallo Ralf,

danke für die schnelle Antwort. Das ist eine Interessante Variante, wo ich dann wahrscheinlich etwas basteln muss, um das mit den Konturen zu haben.
Halbe Sterne währen nicht möglich.

Gibt es da noch eine Alternative?

Danke und Gruß

[Ego]

Hallo b...,

in der Anlage eine VBA-Lösung

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim intStern As Integer
Dim dblBewertung As Double
Dim rngBewertung As Range
Set rngBewertung = ThisWorkbook.Names("Bewertung").RefersToRange
If Not (Intersect(Target, rngBewertung) Is Nothing) Then
    dblBewertung = ThisWorkbook.Names("Bewertung").RefersToRange.Value
    For intStern = 1 To 5
        With ActiveSheet.Shapes("5-Point Star " & intStern)
            If dblBewertung <= intStern - 1 Then
                .Fill.GradientStops(2).Position = 0
                .Fill.GradientStops(3).Position = 0
            ElseIf dblBewertung >= intStern Then
                .Fill.GradientStops(2).Position = 1
                .Fill.GradientStops(3).Position = 1
            Else
                .Fill.GradientStops(2).Position = dblBewertung - intStern + 1
                .Fill.GradientStops(3).Position = dblBewertung - intStern + 1
            End If
        End With
    Next intStern
End If
End Sub

[brooker]

Hallo Ego,

das ist ebenfalls eine sehr interessante Lösung. Sie funktioniert wie sie soll, allerdings verstehe ich den Code usw. nicht so ganz. Wie ist das ganze in einer neuen Datei reproduzierbar?
Woher weiß das VBA welche Sterne es nehmen soll? Hast du die irgendwie benannt? Analog zum Eingabefeld?

[Ego]

Hallo b...,


da die Namen der Sterne (shapes) in deiner Beispieldatei ("5-Point Star 1"; "5-Point Star 2"; ...) passten, habe ich sie nicht verändert und spreche sie im Programm über

Code:

With ActiveSheet.Shapes("5-Point Star " & intStern)

an.

[brooker]

Ah ok! Ich kann also auch dafür individuelle Namen vergeben. Danke.

Ich habe das einmal in meine Datei übertragen. Wahrscheinlich ist es einfach ein Denkfehler, aber ich bekomme dann eine Fehlermeldung.

Fehler beim Kompilieren:

Mehrdeutiger Name: Worksheet-Change

Hier der Code des Tabellenblattes. Woran liegt das, bzw. wo ist mein Denkfehler. Danke schon mal für die Mühe.

Code:

Sub Worksheet_Change(ByVal Target As Excel.Range)

'Wenn Zelle verändert wird, dann führe Marko "Kommentar" aus
If Target.Address = "$AL$8" Then

'Führe Makro "Kommentar" aus
Call Kommentar

End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim intStern As Integer
Dim dblBewertung As Double
Dim rngBewertung As Range
Set rngBewertung = ThisWorkbook.Names("Bewertung").RefersToRange
If Not (Intersect(Target, rngBewertung) Is Nothing) Then
   dblBewertung = ThisWorkbook.Names("Bewertung").RefersToRange.Value
   For intStern = 1 To 5
       With ActiveSheet.Shapes("5-Point Star " & intStern)
           If dblBewertung <= intStern - 1 Then
               .Fill.GradientStops(2).Position = 0
               .Fill.GradientStops(3).Position = 0
           ElseIf dblBewertung >= intStern Then
               .Fill.GradientStops(2).Position = 1
               .Fill.GradientStops(3).Position = 1
           Else
               .Fill.GradientStops(2).Position = dblBewertung - intStern + 1
               .Fill.GradientStops(3).Position = dblBewertung - intStern + 1
           End If
       End With
   Next intStern
End If
End Sub

[Ego]

Hallo b...,

"Es kann nur einen geben."

Nach der Fehlermeldung gehe ich davon aus, dass du in dem Arbeitsblatt eine zweite Sub mit dem Namen Worksheet_Change hast.

Du must die unterschiedlichen Reaktionen auf eine Änderungen in einer Sub zusammenfassen.

[brooker]

Ok, das hat soweit geklappt!

Jetzt wollte ich eine weitere Reihe mit Sternen hinzufügen. Die sollen sich bei der Eingabe in einem anderen Feld verändern. Ich habe die Sterne also kopiert, sie von 6 bis 10 benannten und eine Zelle den Namen
"Ergebnis" gegeben.

Die Ursprungsvariante geht weiterhin, aber das was ich versucht habe geht nicht. Denkfehler?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim intStern As Integer
Dim dblGesamtzufriedenheit As Double
Dim rngGesamtzufriedenheit As Range

Set rngGesamtzufriedenheit = ThisWorkbook.Names("Gesamtzufriedenheit").RefersToRange
If Not (Intersect(Target, rngGesamtzufriedenheit) Is Nothing) Then
   dblGesamtzufriedenheit = ThisWorkbook.Names("Gesamtzufriedenheit").RefersToRange.Value
   For intStern = 1 To 5
       With ActiveSheet.Shapes("Stern: 5 Zacken " & intStern)
           If dblGesamtzufriedenheit <= intStern - 1 Then
               .Fill.GradientStops(2).Position = 0
               .Fill.GradientStops(3).Position = 0
           ElseIf dblGesamtzufriedenheit >= intStern Then
               .Fill.GradientStops(2).Position = 1
               .Fill.GradientStops(3).Position = 1
           Else
               .Fill.GradientStops(2).Position = dblGesamtzufriedenheit - intStern + 1
               .Fill.GradientStops(3).Position = dblGesamtzufriedenheit - intStern + 1
           End If
       End With
   Next intStern
   
End If

Dim intStern2 As Integer
Dim dblErgebnis As Double
Dim rngErgebnis As Range

Set rngErgebnis = ThisWorkbook.Names("Ergebnis").RefersToRange
If Not (Intersect(Target, rngErgebnis) Is Nothing) Then
    dblErgebnis = ThisWorkbook.Names("Ergebnis").RefersToRange.Value
    For intStern2 = 6 To 10
        With ActiveSheet.Shapes("Stern: 5 Zacken " & intStern2)
            If dblErgebnis <= intStern2 - 1 Then
                .Fill.GradientStops(2).Position = 0
                .Fill.GradientStops(3).Position = 0
            ElseIf dblErgebnis >= intStern2 Then
                .Fill.GradientStops(2).Position = 1
                .Fill.GradientStops(3).Position = 1
            Else
                .Fill.GradientStops(2).Position = dblErgebnis - intStern2 + 1
                .Fill.GradientStops(3).Position = dblErgebnis - intStern2 + 1
            End If
        End With
    Next intStern2
    
End If

End Sub

[Ego]

Hallo b...,

ich nehme an, dass du in die Zelle "Ergebnis" auch einen Wert zwischen 0 und 5 einträgst. (Kannst ja mal einen Wert zwischen 5 und 10 eintragen).

Du solltest die Schleife weiterhin von  1 bis 5 laufen lassen, da daraus auch der Füllgrad des Sterns ermittelt wird. Den Namen des Sterns kannst du wie unten angegeben schreiben.

Code:

For intStern2 = 1 To 5
        With ActiveSheet.Shapes("Stern: 5 Zacken " & intStern2 + 5)

ps. Da die Variablen intStern und intStern2 nur in der For-Schleife gesetzt und genutzt werden, kannst du für beide Schleifen die gleiche Variable nutzen und benötigst nicht die Variable intStern2.