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
Moin!
Was hältst Du hiervon (Spalte B Schriftart Wingdings):
Tabelle2| 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
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ß
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
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?
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.
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.
Zitat: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
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.
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
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.