11.04.2016, 15:30
Hallo Ralf,
so sollte es gehen:
so sollte es gehen:
Code:
Sub Eintrag_Urlaub()
Dim rng As Range
Dim gef As Range
Dim loZeile As Long
Dim loRow As Long
Dim loCol As Long
Dim loSpalte As Long
Dim loUTag As Long
Dim loHj As Long
Dim loLetzte As Long
Dim wks As Worksheet
Dim wks2 As Worksheet
Dim dteStart As Date
Dim dteEnde As Date
Dim dteLauf As Date
Set wks2 = Sheets("Urlaubskalender")
Set wks = Sheets("Liste") 'Eintrags-Tabelle
loLetzte = wks.Cells(Rows.Count, 2).End(xlUp).Row 'letzte belegte Zeile in B (2)
If loLetzte = 2 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
For loZeile = 3 To loLetzte
If wks.Cells(loZeile, 1) = "xxx" Then
loSpalte = 1
Else
loSpalte = 2
End If
dteStart = wks.Range("B" & loZeile)
dteEnde = wks.Range("C" & loZeile)
If dteEnde = 0 Then dteEnde = dteStart
For loUTag = dteStart To dteEnde
loCol = ((Month(loUTag) - 1) Mod 6) * 7 + 3
If Month(loUTag) > 6 Then loHj = 39
Set rng = Range(wks2.Cells(3 + loHj, loCol), wks2.Cells(39 + loHj, loCol))
loRow = Application.WorksheetFunction.Match(loUTag, rng, 0) + 2
If wks2.Cells(loRow + loHj, loCol + 2) = "" And loUTag Mod 7 > 1 Then wks2.Cells(loRow + loHj, loCol + 2 + loSpalte) = wks.Cells(loZeile, 4)
loHj = 0
Next
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub