Belegungsplan mit Shapes

Hallo,
ich hoffe, meine Idee und somit meine Bitte sind nicht utopisch. Ich würde gerne einen Belegungsplan mit Shapes gestalten bzw. visualisieren.
Es stehen zunächst 15 Plätze zur Verfügung. Solange ein Platz noch nicht belegt ist, sollten die Grafiken die Farbe rot erhalten. Bei belegt die Farbe grün. Schön wäre, wenn dann drei Tage vor Belegungsende, dass die Grafik mit der Lampe gelb wird und signalisiert, dass der Platz bald frei wird. Die blaue Lampe soll bedeuten, dass der Platz zwar noch belegt ist (grüne Sitzgruppe), aber bereits künftig schon wieder vorgemerkt ist. Toll wäre auch, wenn in der Zelle über dem Shape mit der Sitzgruppe das Ende der jeweiligen Belegung anzeigt wird.
Um die Nummer des jeweiligen Shapes zu ermitteln habe ich sie jeweils mit Makrorekorder markiert und aufgezeichnet. Im Beispiel bilden somit die Grafik 2 (Sitzgruppe) und die Grafik 5 (Lampe) den Platz1
Ich habe einmal eine Beispielsmappe mit der gesponnenen Idee beigefügt und wäre sehr dankbar, wenn ich evtl. Anregungen für 1 oder 2 Plätze bekäme, dann würde ich die weiteren Schritte selbst gerne vollenden und nachvollziehen.
Danke schon jetzt für die Rückmeldungen.
Herzliche Grüße - Wolfgang
https://www.herber.de/bbs/user/133668.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Einfaerben() Dim i As Integer, letzZ As Integer, x As Integer, ii As Integer, xDatum As Date letzZ = Tabelle2.[I1000].End(xlUp).Row xDatum = Date - 3 For i = 1 To 15 Tabelle1.Shapes.Range(Array("Sitz" & i)).Fill.ForeColor.RGB = RGB(255, 0, 0) Tabelle1.Shapes.Range(Array("Lamp" & i)).Fill.ForeColor.RGB = RGB(255, 0, 0) Next For i = 2 To letzZ x = Tabelle2.Cells(i, 12) If Tabelle2.Cells(i, 9) = Date Then Tabelle1.Shapes.Range(Array("Sitz" & x)).Fill.ForeColor.RGB = RGB(64, 130, 63) Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(64, 130, 63) End If If Tabelle2.Cells(i, 10) >= xDatum And Tabelle2.Cells(i, 10) Date Then Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(47, 85, 151) End If If Tabelle2.Cells(i, 8) = "storniert" Then Tabelle1.Shapes.Range(Array("Sitz" & x)).Fill.ForeColor.RGB = RGB(255, 0, 0) Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(255, 0, 0) End If Next End Sub

Hallo Werni,
ich hatte mich noch weiter mit Deinem Code befasst und die Anpassungen versucht. Nach vielem Probieren sollte das soweit klappen. Was ich irgendwie nicht hinbekomme, dass die jeweilige Lampe drei Tage vor Erreichen des Ende-Termins gelb wird. Hättest Du da evtl. eine Idee? Nachfolgend füge ich den angepassten Code bei. Vielleicht fällt Dir da noch etwas auf. Herzlichen Dank schon jetzt wieder.
Viele Grüße - Wolfgang

Option Explicit
Sub Einfaerben()
Dim i As Integer, letzZ As Integer, x As Integer, ii As Integer, xDatum As Date
letzZ = Tabelle2.[I1000].End(xlUp).Row
xDatum = Date - 3
For i = 1 To 15
Tabelle1.Shapes.Range(Array("Sitz" & i)).Fill.ForeColor.RGB = RGB(255, 0, 0)
Tabelle1.Shapes.Range(Array("Lamp" & i)).Fill.ForeColor.RGB = RGB(255, 0, 0)
Next
For i = 2 To letzZ
x = Tabelle2.Cells(i, 12)
If Tabelle2.Cells(i, 9) = Date Then
Tabelle1.Shapes.Range(Array("Sitz" & x)).Fill.ForeColor.RGB = RGB(64, 130, 63)
Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(64, 130, 63)
End If
If Tabelle2.Cells(i, 10) = Date Then
Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(255, 217,  _
102) _
End If
'vorgemerkt nicht eingelöst
If Tabelle2.Cells(i, 9) = Date And Tabelle2.Cells(i, 8) = " _
vorgemerkt" Then
Tabelle1.Shapes.Range(Array("Sitz" & x)).Fill.ForeColor.RGB = RGB(64, 130, 63)
End If
If Tabelle2.Cells(i, 9) > Date And Tabelle2.Cells(i, 8) = "vorgemerkt" Then
Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(47, 85, 151)
End If
'eingelöst
If Tabelle2.Cells(i, 10)  Date And Tabelle2.Cells(i, 8) = "eingelöst" Then
Tabelle1.Shapes.Range(Array("Sitz" & x)).Fill.ForeColor.RGB = RGB(64, 130, 63)
End If
'storniert
If Tabelle2.Cells(i, 8) = "storniert" Then
Tabelle1.Shapes.Range(Array("Sitz" & x)).Fill.ForeColor.RGB = RGB(255, 0, 0)
Tabelle1.Shapes.Range(Array("Lamp" & x)).Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
Next
End Sub

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread