Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1536to1540
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Shapes ansprechen mit VBA

Shapes ansprechen mit VBA
06.02.2017 13:25:26
dome
Guten Tag zusammen,
Habe aus einer PPT-Präsentation eine Schweizerkarte bestehend aus einzelnen Shapes (Kantone). Diese Shapes möchte ich nun mit VBA ansprechen. (Die Shapes befinden sich nicht mehr in der Präsentation, sondern in XLS; einfach rüber kopiert, als Bild)
In dieser XLS-Mappe habe ich bestimmte Werte für jeden Kanton. (resp. FALSCH, hab nur mitte/ost/west und die einzelnen Kantone werden in diese Gruppen aufgeteilt)
Diese Werte sollen nun den einzelnen Shapes zugeordnet und die Shapes entsprechend farblich (ganz bestimmte RGB) markiert werden.
Wie schaffe ich diese Verknüpfung? Könnte mir da allenfalls jemand weiterhelfen?
Ich danke Euch!
Beste Grüsse,
Dome

18
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Shapes ansprechen mit VBA
06.02.2017 15:12:49
Beverly
Hi,
ich nehme an die einzelnen Kantone haben einen Namen? Welchen Zusammenhang gibt es zwischen dem Namen und den Gruppen? Soll die Farbzuweisung nur einmalig sein oder sich ändern? Bei einmaliger Farbzuweisung würde ich das von Hand machen.


AW: Shapes ansprechen mit VBA
06.02.2017 15:33:49
dome
Guten Tag Karin,
Ja, den Shapes/Kantonen habe ich einen Namen vergeben.
Die Unterscheidung ist sprachbedingt (D, F, I) (Die jeweilige Zugehörigkeit ist in einer Input-Tabelle festgehalten, genauso wie die Bevölkerung, nach welcher ich schlussendlich die farblich Unterscheidung haben möchte - welche sich auch ändern kann.
Ich bin in Zwischenzeit etwas weiter gekommen:
(nur mal drei Beispiele)
Irgendwie schaffe ich es aber nicht die gewünschten Farben (RGB) festzuhalten...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = Range("D3") Then    'Wert steht in D3, hier fängt alles an
ActiveSheet.Shapes("Freeform 732").Select    'Glarus
With Selection
.ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
End With
Target.Select
End If
' nächster Kanton
If Target = Range("D4") Then    'Wert steht in D4
ActiveSheet.Shapes("Freeform 733").Select    'St.Gallen
With Selection
.ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
End With
Target.Select
End If
' nächster Kanton
If Target = Range("D5") Then    'Wert steht in D5
ActiveSheet.Shapes("Freeform 734").Select    'Basel-Land
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 >= 900000        'Werte und Relationen anpassen
fctFarbe = 10        'Farbwerte entsprechend ändern
Case Is >= 250000
fctFarbe = 11
Case Is >= 100000
fctFarbe = 4
Case Is >= 35000
fctFarbe = 5
Case Is >= 10000
fctFarbe = 6
Case Else
fctFarbe = 9
End Select
End Function

Anzeige
AW: Shapes ansprechen mit VBA
06.02.2017 15:36:55
dome
Sorry, wollte noch eine Datei dran hängen..

Die Datei https://www.herber.de/bbs/user/111249.xlsm wurde aus Datenschutzgründen gelöscht


AW: Shapes ansprechen mit VBA
06.02.2017 16:20:28
Beverly
Hi,
man muss die Schapes nicht selektieren um ihnen eine Farbe zuzuweisen:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = Range("D3") Then    'Wert steht in D3
'Glarus
ActiveSheet.Shapes("Freeform 732").Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
ElseIf Target = Range("D4") Then    'Wert steht in D4
'St.Gallen
ActiveSheet.Shapes("Freeform 733").Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
ElseIf Target = Range("D5") Then    'Wert steht in D5
'Basel-Land
ActiveSheet.Shapes("Freeform 734").Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
ElseIf Target = Range("D6") Then    'Wert steht in D6
'Genf
ActiveSheet.Shapes("Freeform 735").ShapeRange.Fill.ForeColor.SchemeColor = fctFarbe( _
Target.Value)
' .... usw.
End Sub

Und die Farbermittlung so:
Private Function fctFarbe(dblWert As Double) As Byte
If dblWert >= 900000 Then
fctFarbe = 10
ElseIf dblWert >= 250000 And dblWert = 100000 And dblWert = 35000 And dblWert = 10000 And dblWert 



Anzeige
Korrektur
06.02.2017 16:22:06
Beverly
Sorry, da hatte ich für die 4. Anweisung etwas vergessen zu löschen
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = Range("D3") Then    'Wert steht in D3
'Glarus
With ActiveSheet.Shapes("Freeform 732").Fill.ForeColor.SchemeColor = fctFarbe(Target. _
Value)
ElseIf Target = Range("D4") Then    'Wert steht in D4
'St.Gallen
ActiveSheet.Shapes("Freeform 733").Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
ElseIf Target = Range("D5") Then    'Wert steht in D5
'Basel-Land
ActiveSheet.Shapes("Freeform 734").Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
ElseIf Target = Range("D6") Then    'Wert steht in D6
'Genf
ActiveSheet.Shapes("Freeform 735").Fill.ForeColor.SchemeColor = fctFarbe(Target.Value)
' .... usw.
End Sub


Anzeige
AW: Korrektur
06.02.2017 16:42:54
dome
Hi Karin,
Ich danke Dir für Deinen Input. Hab das gleich umgesetzt, funktioniert hervorragend, vielen Dank.
Das "With" vor ActiveSheet muss ich jedes Mal davor einfügen oder?
Ich möchte den Shapes nun ganz bestimmte RGB-Farben zuweisen, siehe Beispielmappe. Meinst Du, Du könntest mir noch zeigen, wie ich diese Werte jeweils übermitteln kann?
Einen schönen Abend..
Grüsse,
Dome
AW: Korrektur
06.02.2017 16:49:30
Beverly
Hi,
also irgenwie ist heute nicht mein Tag...
Das With muss auf jeden Fall weg - korrekt ist es so wie es ab der 1. ElseIf-Anweisung steht.
Die Farben werden doch zugewisen so wie es in deiner Mappe im Code in der Private Function fctFarbe(dblWert As Double) As Byte steht.


Anzeige
Vereinfachung
06.02.2017 17:26:59
Beverly
Hi,
übrigens kann man den gesamten Code wesentlich vereinfachen, da der Name der Freihandform in der Nachbarspalte steht:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target.Cells(1), Range("D3:D28")) Is Nothing Then _
ActiveSheet.Shapes(Target.Offset(0, -1).Value).Fill.ForeColor.SchemeColor = _
fctFarbe(Target.Value)
End Sub
Private Function fctFarbe(dblWert As Double) As Byte
If dblWert >= 900000 Then
fctFarbe = 10
ElseIf dblWert >= 250000 And dblWert = 100000 And dblWert = 35000 And dblWert = 10000 And dblWert 


Anzeige
AW: Vereinfachung
06.02.2017 18:21:49
Dome
Hi Karin,
Vielen Dank für die Vereinfachung. Bin fast nicht mehr nachgekommen mit kopieren. hihi
Mist, Du hast Recht, ich habe Dir die gewünschten Farben (in RGB) gar nicht mitgegeben. Holen wir das doch gleich nach:

Private Function fctFarbe(dblWert As Double) As Byte
If dblWert >= 900000 Then
fctFarbe = 10        'RGB(70, 169, 180)
ElseIf dblWert >= 250000 Then
fctFarbe = 11        'RGB(121, 186, 196)
ElseIf dblWert >= 100000 Then
fctFarbe = 4         'RGB(162, 205, 200)
ElseIf dblWert >= 35000 Then
fctFarbe = 5         'RGB(198, 223, 222)
ElseIf dblWert >= 10000 Then
fctFarbe = 6         'RGB(228, 239, 242)
Else
fctFarbe = 9         'RGB(255, 255, 255)
End If
End Function
Hab vielen Dank für Deine Hilfe!
Beste Grüsse und einen schönen Abend.
Dome
Anzeige
Gelöst
07.02.2017 08:16:39
Dome
Guten Morgen Karin,
Habs gerade selber hinbekommen:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target.Cells(1), Range("D3:D28")) Is Nothing Then _
ActiveSheet.Shapes(Target.Offset(0, -1).Value).Fill.ForeColor.RGB = _
fctFarbe(Target.Value)
End Sub
Private Function fctFarbe(dblWert As Long) As Long
If dblWert >= 900000 Then
fctFarbe = RGB(70, 169, 180)
ElseIf dblWert >= 250000 And dblWert = 100000 And dblWert = 35000 And dblWert = 10000 And dblWert 
Ich danke Dir ganz herzlich für Deine Hilfe. Wieder was dazu gelernt.
Beste Grüsse
Dome
Anzeige
AW: Gelöst
07.02.2017 12:58:41
Dome
Hi Karin,
Eine ergänzende Frage hätte ich noch:
Wenn ich die ausgelesenen dblWerte via Formel aus einem anderen Tabellenblatt haben möchte, funktioniert der Code nicht mehr. Was ist der Grund dafür? Oder mache ich etwas falsch?
Beste Grüsse,
Dome
Was heisst "funktioniert der Code nicht mehr" ?
07.02.2017 13:14:46
EtoPHG

AW: Was heisst "funktioniert der Code nicht mehr" ?
07.02.2017 13:25:16
Dome
Guten Tag,
Die Werte, von welchen abhängt, welche Farbe das Shape hat, werden von einer anderen Mappe (z.B. Tabelle2) hergeholt.
Wenn ich nun ganz simpel in z.B. Tabelle1 via "=Zelle aus anderem Datenblatt" die Felder mit Formeln fülle und auf dem anderen Datenblatt (Tabelle2) die Werte ändere, passt es mir die Farben nicht an.
Wenn ich allerdings direkt in die Felder schreibe (Tabelle1) und die Daten nicht von wo anders herhole, ändert es die Farbe. Allerdings auch nur ein einziges Mal. Das ist etwas schade.
Beste Grüsse,
Dome
Anzeige
In diesem Fall das Change-Ereignis für die Zellen
07.02.2017 13:47:41
Beverly
Hi,
...im anderen Tabellenblatt benutzen um die Änderung der Formelergebnisse durch Eingaben zu überwachen.
Dass die Farbe nur einmalig gändert wird stimmt nicht - es hängt davon ab, welchen Zahlenwert du einträgst, welche Farbe dem Shape zugewiesen wird. Wenn du also zuerst 35.000 und anschließend 38.000 eintägst, kann sich die Farbe nicht ändern, da beide Werte im betreffenden Werteintervall liegen. Gibst du aber beim zweitenmal nicht 38.000 sondern 5.000 ein, siehst du, dass sich die Farbe des Shapes ändert.


Etwas aufgeräumt....
07.02.2017 14:31:43
EtoPHG
Hallo Dome,
Hier ist mal ein etwas aufgeräumtere Version Deiner Datei.
1. Die Freeform-Namen sind weg. Macht ja keinen Sinn, da jeder Kanton ein eindeutiges Kürzel hat.
2. Egal ob mit Formeln oder mit direktem Überschreiben der Formeln/Werte es wird die Farbe des betroffenen Shapes angepasst.
3. Jetzt sind mal Formeln drin und mit F9 ändern alle Werte (und Farben!) zufällig (Werte werden aus Tabelle2) gezogen.
Und hier die Beispielmappe
Gruess Hansueli
Anzeige
AW: Etwas aufgeräumt....
07.02.2017 16:11:18
Dome
Guten Abend Karin,
guten Abend Hansueli,
Vielen herzlichen Dank für Eure Hilfe. Was für unglaublich tolle Lösungen, das sieht super aus!
Beide Vorschläge habe ich überprüft, beides funktioniert reibungslos.
Ich lasse mir die Werte aus einem Makro übergeben. Bei jeder Neuberechnung ändert es mir die Werte und Farben. Da Prozentwerte übergeben werden bin ich zuerst erschrocken, dass die Karte nicht mehr sichtbar war (weiss auf weiss). Habe dann die Range verändert und siehe da..
Einfach nur Wow! Danke Euch beiden.
Ich wünsche Euch einen schönen Feierabend und grüsse herzlich aus der Schweiz.
Dome
AW: Etwas aufgeräumt....
10.02.2017 12:53:26
Dome
Guten Tag zusammen,
Bitte entschuldigt, dass ich mich nochmals an Euch wenden muss, aber mehrere Versuche mit zwei Shapes (resp. Gruppierung) und einem zweiten Wertebereich sind kläglich gescheitert.
Ziel:
Es wäre schön eine zweite Shape-Gruppierung zu haben, eine also auf kantonaler Basis, die andere regional, mit anderen Farben und Werten.
(Regional heisst, dass die Kantone einer bestimmten Region (Ost, Mitte, West) angehören, welche eindeutig zugeordnet sind.)
Wie bekomme ich denn das wieder hin?
Zusatproblem
07.02.2017 13:15:57
Beverly
Hi,
wie meinst du das "via Formel"?


Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige