|
Vielleicht hilft der bereits funktionierende Code:
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub Kalender_DateClick(ByVal DateClicked As Date)
On Error Resume Next
Dim datecellrow As String 'Variable Zeilen-Nr. Datumsfeld
Dim datecellcol As String 'Variable Spalten-Nr. Datumsfeld
Dim h As Range 'Variable für Spalte JKW(H)
Dim hwert As String 'Variable Wert Spalte JKW(H)
Dim hrow As String 'Variable für Zeilen-Nr. JKW(H)
Dim hcol As String 'Variable für Spalten-Nr. JKW(H)
Dim eSp As Long 'Variable erste Spalte Wochenplan
Dim lSp As Long 'Variable letzte Spalte Wochenplan
Dim wp As Range 'Zähler Spalten WP
Dim WertJKW As String 'Variable Wert WP
Dim rowjkw As String 'Variable Zeilen-Nr. WP
Dim coljkw As String 'Variable Spalten-Nummer WP
Dim tc As Range 'Variable Ziel-Adresse
Dim tcadr As String 'Variable Ziel-Adresse ohne $
Dim z As Range 'Variable für Schlaufe z - Spalten E,F,G
Dim zwert As String 'Variable für Wert, Spalte E,F,G
Dim zcol As String 'Variable für Spalten-Nr., Spalten E,F,G
Dim zrow As String 'Variable für Zeilen-Nr., Spalten E,F,G
ActiveCell.Value = DateClicked 'aktive Zelle = geklicktes Datum
datecellrow = ActiveCell.row 'aktive Zeilen-Nr.
datecellcol = ActiveCell.Column 'aktive Spalten-Nr.
eSp = Range("K10").Column 'erste Spalte Wochenplan
lSp = Range("JL10").Column 'letzte Spalte Wochenplan
For Each h In Range(Cells(datecellrow, 8), Cells(datecellrow, 8)) 'liest jede Zeile, Spalte H
hwert = h.Value 'liest Wert, Spalte H
hrow = h.row 'liest Zeilen-Nr., Spalte H
hcol = h.Column 'liest Spalten-Nr., Spalte H
If hwert <> "1900/52" Then 'wenn Spalte H, Wert nicht 1900/52
For Each wp In Range(Cells(10, eSp), Cells(10, lSp)) 'liest Spalten J/KW durch
rowjkw = wp.row
coljkw = wp.Column 'Spalten-Nummer
WertJKW = wp.Value 'Wert Spalte
If WertJKW = hwert Then Exit For 'Wenn End-Datum = J/KW
Next wp 'Nächster Schlaufendurchlauf wp
Set tc = Range(Cells(h.row, wp.Column).Address) 'ermittelte Spalten-Adresse
tcadr = tc.Address(rowabsolute:=False, ColumnAbsolute:=False) 'Spalten-Adresse ohne $
Cells(h.row, wp.Column).Activate 'Ziel-Zelle aktivieren
With Selection.Borders 'Dick rot umranden
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = -1
.Weight = xlMedium
End With
End If
Next h
If DateClicked <> "" Then 'Wenn Datum nicht leer
Cells(Selection.row, 6).Activate 'Spalte F mit schwarzer Schriftfarbe
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Cells(Selection.row, 7).Activate 'Spalte G mit schwarzer Schriftfarbe
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
End If
Application.EnableEvents = False
ActiveCell.Offset(0, -2).Select '2 Zellen nach links/zurück zu Datumsfeld springen
Application.EnableEvents = True
Unload Kalender
End Sub
--------------------------------------------------------------------------
Private Sub Worksheet_Deactivate()
Application.OnKey "{del}"
End Sub
------------------------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Range("E14:E77"), Target) Is Nothing Then
Kalender.Show
If Target.Value = "" Then
Cells(Selection.row, 6).Activate
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Cells(Selection.row, 7).Activate
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Application.EnableEvents = False
ActiveCell.Offset(0, -2).Select
Application.EnableEvents = True
End If
End If
|