Verleihkalender HomeOffice

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Guten Morgen!
Ich hab dir mal eine Funktionalität reingebaut, die die Verfügbarkeit für den nächsten Tag regelt.
Allerdings bezieht sich das auch streng auf die von Dir angegebenen Daten, daher weiß ich nicht, ob du in der Lage bist, das zu adaptieren.
Funktion:
Wird im Bereich der Personen eine Zahl eingetragen, werden die anderen verfügbaren Geräte ins Auswahlmenü aufgenommen. Dies gilt bei jedem Eintrag und auch für den nächsten Tag. "Nächster Tag" war allerdings nicht durchgängig definiert, daher hab ich das einfach mal angenommen: Freitags verliehene Geräte sind am MO noch nicht wieder verfügbar.
Schwäche: Es wird 1 Werktag vorwärts geändert, nachträgliche Änderungen erzeugen keinen Fehler in der Wochenplanung.
Das mit dem "H" hab ich nicht verstanden und wird auch nicht in meinem Code als Bdingung berücksichtigt, aber als Eintrag mit bereitgestellt.
Ich hoffe, das kann dir als Basis für die weitere Entwicklung dienen.
https://www.herber.de/bbs/user/150503.xlsm
Viel Erfolg
Gruß, MCO

Private Sub Worksheet_Change(ByVal Target As Range) Dim zl_max As Long Dim rng As Range zl_max = Range("A4").End(xlDown).Row If Not Application.Intersect(Rows("4:" & zl_max), Target) Is Nothing Then Set rng = Target rng.Interior.Color = 32 rng.Offset(0, 1).Interior.Color = 32 verfügb_Geräte rng End If End Sub

Sub verfügb_Geräte(Verleih_tag As Range) Dim Summer_ger As Long Dim Verleih_rng As Range, num_rng As Range Dim an As Long Dim rng As Range Dim zl_max As Long On Error Resume Next zl_max = Range("A4").End(xlDown).Row Set Verleih_rng = Range(Cells(4, Verleih_tag.Column), Cells(zl_max, Verleih_tag.Column)) Set num_rng = Verleih_rng.SpecialCells(xlCellTypeConstants, xlNumbers) If Weekday(Cells(3, Verleih_tag.Column).Offset(0, 1), vbMonday) > 5 Then nächster_Tag = 10 - Weekday(Cells(3, Verleih_tag.Column).Offset(0, 1), vbMonday) Else nächster_Tag = 2 End If Verleih_rng.Offset(, nächster_Tag - 1).Interior.Color = xlNone If Not num_rng Is Nothing Then Summe_ger = WorksheetFunction.Sum(num_rng) anz = WorksheetFunction.Count(Verleih_rng.SpecialCells(xlCellTypeConstants, xlNumbers)) Select Case Summe_ger Case 1: verfügb = "2,3" Case 2: verfügb = "1,3" Case 3 And anz = 1: verfügb = "1,2" Case 3 And anz = 2: verfügb = "3" Case 4: verfügb = "2" Case 5: verfügb = "1" Case 6: verfügb = "-" End Select num_rng.Interior.ColorIndex = 37 num_rng.Offset(, nächster_Tag - 1).Interior.ColorIndex = 37 Else verfügb = "1,2,3" End If Set rng = Verleih_rng.Resize(, nächster_Tag - 1) With rng.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=verfügb & ",H" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With Set Verleih_rng = Nothing Set num_rng = Nothing Set rng = Nothing End Sub

Guten Morgen, Franz!
Die Auswahl der verleihbaren Geräte hab ich komplett geändert bzw vereinfacht.
Auch die gesperrten Tage hab ich eingebaut.
Allerdings ergibt sich dadurch eine "Unstimmigkeit": Ein Gerät, dass am Do verliehen wird, ist Mo nicht verfügbar. Ein Gerät, dass am Fr. verliehen wird, überschreibt diese Vorgabe und ist nur selbst am Mo nicht verfügbar. Dafür hab ich leider keine Lösung gefunden. Daher hab ich die Färbung der Zellen mal stehengelassen für den gesperrten Zeitraum.
Neu: Die Färbung wird gelöscht, wenn das Gerät gelöscht wird, nur am Gerät, nicht der ganze Tag.
Bau das mal ein.


Sub verfügb_Geräte(Verleih_tag As Range)
Dim Verleih_rng As Range, num_rng As Range
Dim an As Long
Dim rng As Range
Dim zl_max As Long
On Error Resume Next
Dim verfügb As String
Application.EnableEvents = False
zl_max = Range("A4").End(xlDown).Row
Set Verleih_rng = Range(Cells(4, Verleih_tag.Column), Cells(zl_max, Verleih_tag.Column))
Set num_rng = Verleih_rng.SpecialCells(xlCellTypeConstants, xlNumbers)
Verleih_wochentag = Weekday(Cells(3, Verleih_tag.Column), vbMonday)
Select Case Verleih_wochentag
Case 1, 6: nächster_Tag = 3
Case 2, 3, 7: nächster_Tag = 2
Case 4: nächster_Tag = 5
Case 5: nächster_Tag = 4
End Select
If Verleih_tag = "" Then
Verleih_tag.Interior.Color = xlNone
Verleih_rng.Offset(, nächster_Tag - 1).Interior.Color = xlNone
End If
verfügb = "1,2,3,4,5,H"
If Not num_rng Is Nothing Then
For Each num In num_rng
verfügb = Replace(verfügb, num & ",", "")
Next
num_rng.Interior.ColorIndex = 37
num_rng.Offset(, nächster_Tag - 1).Interior.ColorIndex = 37
End If
Set rng = Verleih_rng.Resize(, nächster_Tag)
Werte_einschränken rng, verfügb
Set Verleih_rng = Nothing
Set num_rng = Nothing
Set rng = Nothing
Application.EnableEvents = 1
End Sub
Sub Werte_einschränken(Bereich As Range, Werte As String)
With Bereich.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Werte
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub

Gruß, MCO

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread