Zellenmarkierung mittels Userform
26.05.2015 00:34:28
Torsten
Habe ich auch die Möglichkeit diesen Code in einem Modul zu öffnen?
Der Code wurde mir von einem User hier im Forum geschrieben.
Ein weiteres Ereignis mit Target (Rechtsklick) welches im Tabellenblatt liegt benötige ich dringend, welches sich mit diesem Ereignis Rechtsklick nicht verträgt.
Ich habe versucht "Target" gegen "Activecell" zu ersetzen, aber leider ohne Erfolg.
Ich möchte den folgenden Code dann Anschließend über ein Commondbutton_Click1 öffnen.
Die bereits erstellte Datei/funktionierende Datei ist im Verlauf dieses Threads vom User "fcs" erstellt.
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim Spa1&, Spa2&, Zei_Abwesend&, Zei_Vertretung&, Abt_Abwesend, Name_Abw As String, _
Schicht_Abw
Dim dat_1, dat_2
Dim Zei_List&, Zei_L&, Spa_L&
Dim arrListbox()
'Die folgenden Konstanten müssen ggf. angpasst werden, wenn der Aufbau des Tabellenblattes _
geändert wird
Const Spa_Farbe = 1 'Spalte mit farbigeb Zellen zu den Namen
Const Spa_Schicht& = 3 'Spalte C - Spalte mit Abteilung
Const Spa_Abt& = 4 'Spalte D - Spalte mit Abteilungen
Const Spa_Name& = 5 'Spalte E - Spalte mit Namen
Const Spa_Datum1& = 6 'Spalte F - 1. Spalte mit einem Kalender-Datum
Const Zei_Name1& = 6 ' 1. Zeile mit einem Namen
Const Zei_Datum& = 5 'Zeile mit Datumswerten
With Target
Zei_L = Cells(Rows.Count, Spa_Name).End(xlUp).Row
Spa_L = Cells(Zei_Datum, Columns.Count).End(xlToLeft).Column
'Prüfung, ob nur Zellen in einer Zeile markiert wurden und 1. Zelle des Bereichs Inhalt _
hat.
If .Rows.Count = 1 And Target.Cells(1, 1) "" Then
Select Case .Column
Case Spa_Datum1 To Spa_L
Select Case .Row
Case Zei_Name1 To Zei_L
Cancel = True
Spa1 = .Column
Spa2 = Spa1 + .Columns.Count - 1
Zei_Abwesend = .Row
Abt_Abwesend = Me.Cells(Zei_Abwesend, Spa_Abt).Value
Name_Abw = Me.Cells(Zei_Abwesend, Spa_Name).Text
Schicht_Abw = Me.Cells(Zei_Abwesend, Spa_Schicht).Value
dat_1 = Me.Cells(Zei_Datum, Spa1).Value
dat_2 = Me.Cells(Zei_Datum, Spa2).Value
ReDim arrListbox(Zei_Name1 To Zei_L, 1 To 4)
Zei_List = LBound(arrListbox, 1)
'im Zeitraum verfügbare Vertreter in Auswahlliste aufnehmen
For Zei_Vertretung = Zei_Name1 To Zei_L
'Prüfen, ob Vertreter im Zeitraum verfühbar
If Application.WorksheetFunction.CountA(Range(Cells( _
Zei_Vertretung, Spa1), _
Cells(Zei_Vertretung, Spa2))) = 0 Then
arrListbox(Zei_List, 1) = Cells(Zei_Vertretung, Spa_Schicht) _
arrListbox(Zei_List, 2) = Cells(Zei_Vertretung, Spa_Abt)
arrListbox(Zei_List, 3) = Cells(Zei_Vertretung, Spa_Name)
arrListbox(Zei_List, 4) = Zei_Vertretung
Zei_List = Zei_List + 1
End If
Next
With UF_Vertretung
.txbAbt = Abt_Abwesend
.txbName = Name_Abw
.txbSchicht = Schicht_Abw
.txbDatum1 = Format(dat_1, "DD.MM.YYYY")
.txbDatum2 = Format(dat_2, "DD.MM.YYYY")
If Zei_List > LBound(arrListbox, 1) Then
.lbxVertretung.List = arrListbox
With .lbxVertretung
'leere Zeilen der Auswahlliste löschen
For Zei_List = .ListCount - 1 To 0 Step -1
If .List(Zei_List, 2) = "" Then
.RemoveItem (Zei_List)
Else
Exit For
End If
Next
End With
End If
.Show
If .Tag = "OK" Then
Zei_Vertretung = Val(.lbxVertretung.Value)
'Zellen bei abwesender Person färben
With Range(Cells(Zei_Abwesend, Spa1), Cells(Zei_Abwesend, _
Spa2))
.Interior.Color = Cells(Zei_Vertretung, Spa_Farbe). _
Interior.Color
End With
'Zellen bei Vertreter färben und Abteilung der vertretenen _
Person eintragen
With Range(Cells(Zei_Vertretung, Spa1), Cells( _
Zei_Vertretung, Spa2))
.Value = Abt_Abwesend
.Interior.Color = Cells(Zei_Vertretung, Spa_Farbe). _
Interior.Color
End With
End If
Unload UF_Vertretung
End With
Case Else
'do nothing
End Select
Case Else
'do nothing
End Select
End If
End With
End Sub