Sub KrankTageImBlauenTeil()
Dim i As Integer, n As Integer
n = 9
For i = 1 To Month(Range("I4") - Range("H4") + 1)
If i = 1 Then
Cells(n, "B") = Range("H4")
Cells(n, "C") = DateSerial(Year(Range("H4")), Month(Range("H4")) + 1, 1) - 1
Cells(n, "D") = Format(Range("H4"), "MMMM")
Cells(n, "E") = Format(Range("H4"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(i + 8, "B"), Cells(i + 8, "C"))
ElseIf i > 1 And i < Month(Range("I4") - Range("H4") + 1) Then
Cells(n, "B") = DateSerial(Year(Cells(n - 1, "B")), Month(Cells(n - 1, "B")) + 1, 1)
Cells(n, "C") = DateSerial(Year(Cells(n, "B")), Month(Cells(n, "B")) + 1, 1) - 1
Cells(n, "D") = Format(Cells(n, "B"), "MMMM")
Cells(n, "E") = Format(Cells(n, "C"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(n, "B"), Cells(n, "C"))
ElseIf i = Month(Range("I4") - Range("H4") + 1) Then
Cells(n, "B") = DateSerial(Year(Cells(n - 1, "B")), Month(Cells(n - 1, "B")) + 1, 1)
Cells(n, "C") = Range("I4")
Cells(n, "D") = Format(Cells(n, "B"), "MMMM")
Cells(n, "E") = Format(Cells(n, "C"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(n, "B"), Cells(n, "C"))
End If
n = n + 1
Next
End Sub
Public Function NettoArbTage(Beginn As Date, Ende As Date, Optional ArbeitsTage As Range, Optional FreieTage As Range)
'Berechnung NettoArbeitstage mit Berücksichtigung der Feiertage + optional zusätzliche ArbeitsTage
'und / oder zusätzliche freie Tage!
Application.Volatile
If IsDate(Beginn) And IsDate(Ende) And Beginn < Ende Then
Do While Beginn <= Ende
If ArbeitsTage Is Nothing And FreieTage Is Nothing Then
If ATag(Beginn) = 1 Then
NettoArbTage = NettoArbTage + 1
End If
ElseIf ArbeitsTage Is Nothing Then
If ATag(Beginn) = 1 And Application.IsNumber(Application.Match(CLng(Beginn), FreieTage, 0)) = False Then
NettoArbTage = NettoArbTage + 1
End If
ElseIf FreieTage Is Nothing Then
If ATag(Beginn) = 1 Or Application.IsNumber(Application.Match(CLng(Beginn), ArbeitsTage, 0)) Then
NettoArbTage = NettoArbTage + 1
End If
Else
If ATag(Beginn) = 1 And Application.IsNumber(Application.Match(CLng(Beginn), FreieTage, 0)) = False _
Or Application.IsNumber(Application.Match(CLng(Beginn), ArbeitsTage, 0)) Then
NettoArbTage = NettoArbTage + 1
End If
End If
Beginn = Beginn + 1
Loop
Else
NettoArbTage = 0
End If
End Function
Public Function ATag(Datum As Date) As Integer
'***********************************************************
'* !!! Achtung saarländische Feiertage, bitte anpassen !!! *
'***********************************************************
Dim Feiertage(12) As Date
Dim Jahr%, WTag%, i%
Jahr = CInt(Format(Datum, "yyyy"))
WTag = CInt(Weekday(Datum, 2))
ATag = 1
If WTag > 5 Then
ATag = 0 ' Wochenende
Else
Feiertage(0) = (Ostersonntag(Jahr)) - 2 ' Karfreitag
Feiertage(1) = (Ostersonntag(Jahr)) + 1 ' Ostermontag
Feiertage(2) = (Ostersonntag(Jahr)) + 39 ' Christi Himmelfahrt
Feiertage(3) = (Ostersonntag(Jahr)) + 50 ' Pfingstmontag
Feiertage(4) = (Ostersonntag(Jahr)) + 60 ' Fronleichnam
Feiertage(5) = CDate("01.01." & Jahr) ' Neujahr
Feiertage(6) = CDate("01.05." & Jahr) ' 1.Mai
Feiertage(7) = CDate("15.08." & Jahr) ' Maria Himmelfahrt
If Jahr < 1990 Then
Feiertage(8) = CDate("17.06." & Jahr) ' Tag der deutschen Einheit
Else
Feiertage(8) = CDate("03.10." & Jahr)
End If
Feiertage(9) = CDate("01.11." & Jahr) ' Allerheiligen
Feiertage(10) = CDate("25.12." & Jahr) ' 1. Weihnachtstag
Feiertage(11) = CDate("26.12." & Jahr) ' 2.Weihnachtstag
' Ist das Datum ein Feiertag?
For i = 0 To 11
If Datum = Feiertage(i) Then
ATag = 0
Exit For
End If
Next i
End If
End Function
Public Function Ostersonntag(Jahr As Integer) As Date
Dim intA As Integer, intB As Integer, intC As Integer, intD As Integer
Dim intE As Integer, intF As Integer, intG As Integer, intH As Integer
Dim intI As Integer, intK As Integer, intL As Integer, intM As Integer
Dim intN As Integer, intP As Integer
Application.Volatile
Select Case Jahr
Case Is >= 1900
intA = Jahr Mod 19
intB = Int(Jahr / 100)
intC = Jahr Mod 100
intD = Int(intB / 4)
intE = intB Mod 4
intF = Int((intB + 8) / 25)
intG = Int((intB - intF + 1) / 3)
intH = (19 * intA + intB - intD - intG + 15) Mod 30
intI = Int(intC / 4)
intK = intC Mod 4
intL = (32 + 2 * intE + 2 * intI - intH - intK) Mod 7
intM = Int((intA + 11 * intH + 22 * intL) / 451)
intN = Int((intH + intL - 7 * intM + 114) / 31)
intP = (intH + intL - 7 * intM + 114) Mod 31
Ostersonntag = DateSerial(Jahr, intN, intP + 1)
End Select
End Function
Gruß Jürgen
Da war noch ein kleiner Fehler drin!
Backowe
Hi,
| VBA-Code: | Sub KrankTageImBlauenTeil()
Dim i As Integer, n As Integer, AnzMon
n = 9
AnzMon = DateDiff("M", Range("H4"), Range("I4")) + 1
Range("A9:F" & Cells(8, "A").End(xlDown).Row).ClearContents
For i = 1 To AnzMon
If i = 1 Then
Cells(n, "A") = "Schmidt" '<-- damit ein Name da steht ;o)
Cells(n, "B") = Range("H4")
Cells(n, "C") = DateSerial(Year(Range("H4")), Month(Range("H4")) + 1, 1) - 1
Cells(n, "D") = Format(Range("H4"), "MMMM")
Cells(n, "E") = Format(Range("H4"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(i + 8, "B"), Cells(i + 8, "C"))
ElseIf i > 1 And i < AnzMon Then
Cells(n, "A") = "Schmidt"
Cells(n, "B") = DateSerial(Year(Cells(n - 1, "B")), Month(Cells(n - 1, "B")) + 1, 1)
Cells(n, "C") = DateSerial(Year(Cells(n, "B")), Month(Cells(n, "B")) + 1, 1) - 1
Cells(n, "D") = Format(Cells(n, "B"), "MMMM")
Cells(n, "E") = Format(Cells(n, "C"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(n, "B"), Cells(n, "C"))
ElseIf i = AnzMon Then
Cells(n, "A") = "Schmidt"
Cells(n, "B") = DateSerial(Year(Cells(n - 1, "B")), Month(Cells(n - 1, "B")) + 1, 1)
Cells(n, "C") = Range("I4")
Cells(n, "D") = Format(Cells(n, "B"), "MMMM")
Cells(n, "E") = Format(Cells(n, "C"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(n, "B"), Cells(n, "C"))
End If
n = n + 1
Next
End Sub
Public Function NettoArbTage(Beginn As Date, Ende As Date, Optional ArbeitsTage As Range, Optional FreieTage As Range)
'Berechnung NettoArbeitstage mit Berücksichtigung der Feiertage + optional zusätzliche ArbeitsTage
'und / oder zusätzliche freie Tage!
Application.Volatile
If IsDate(Beginn) And IsDate(Ende) And Beginn < Ende Then
Do While Beginn <= Ende
If ArbeitsTage Is Nothing And FreieTage Is Nothing Then
If ATag(Beginn) = 1 Then
NettoArbTage = NettoArbTage + 1
End If
ElseIf ArbeitsTage Is Nothing Then
If ATag(Beginn) = 1 And Application.IsNumber(Application.Match(CLng(Beginn), FreieTage, 0)) = False Then
NettoArbTage = NettoArbTage + 1
End If
ElseIf FreieTage Is Nothing Then
If ATag(Beginn) = 1 Or Application.IsNumber(Application.Match(CLng(Beginn), ArbeitsTage, 0)) Then
NettoArbTage = NettoArbTage + 1
End If
Else
If ATag(Beginn) = 1 And Application.IsNumber(Application.Match(CLng(Beginn), FreieTage, 0)) = False _
Or Application.IsNumber(Application.Match(CLng(Beginn), ArbeitsTage, 0)) Then
NettoArbTage = NettoArbTage + 1
End If
End If
Beginn = Beginn + 1
Loop
Else
NettoArbTage = 0
End If
End Function
Public Function ATag(Datum As Date) As Integer
'***********************************************************
'* !!! Achtung saarländische Feiertage, bitte anpassen !!! *
'***********************************************************
Dim Feiertage(12) As Date
Dim Jahr%, WTag%, i%
Jahr = CInt(Format(Datum, "yyyy"))
WTag = CInt(Weekday(Datum, 2))
ATag = 1
If WTag > 5 Then
ATag = 0 ' Wochenende
Else
Feiertage(0) = (Ostersonntag(Jahr)) - 2 ' Karfreitag
Feiertage(1) = (Ostersonntag(Jahr)) + 1 ' Ostermontag
Feiertage(2) = (Ostersonntag(Jahr)) + 39 ' Christi Himmelfahrt
Feiertage(3) = (Ostersonntag(Jahr)) + 50 ' Pfingstmontag
Feiertage(4) = (Ostersonntag(Jahr)) + 60 ' Fronleichnam
Feiertage(5) = CDate("01.01." & Jahr) ' Neujahr
Feiertage(6) = CDate("01.05." & Jahr) ' 1.Mai
Feiertage(7) = CDate("15.08." & Jahr) ' Maria Himmelfahrt
If Jahr < 1990 Then
Feiertage(8) = CDate("17.06." & Jahr) ' Tag der deutschen Einheit
Else
Feiertage(8) = CDate("03.10." & Jahr)
End If
Feiertage(9) = CDate("01.11." & Jahr) ' Allerheiligen
Feiertage(10) = CDate("25.12." & Jahr) ' 1. Weihnachtstag
Feiertage(11) = CDate("26.12." & Jahr) ' 2.Weihnachtstag
' Ist das Datum ein Feiertag?
For i = 0 To 11
If Datum = Feiertage(i) Then
ATag = 0
Exit For
End If
Next i
End If
End Function
Public Function Ostersonntag(Jahr As Integer) As Date
Dim intA As Integer, intB As Integer, intC As Integer, intD As Integer
Dim intE As Integer, intF As Integer, intG As Integer, intH As Integer
Dim intI As Integer, intK As Integer, intL As Integer, intM As Integer
Dim intN As Integer, intP As Integer
Application.Volatile
Select Case Jahr
Case Is >= 1900
intA = Jahr Mod 19
intB = Int(Jahr / 100)
intC = Jahr Mod 100
intD = Int(intB / 4)
intE = intB Mod 4
intF = Int((intB + 8) / 25)
intG = Int((intB - intF + 1) / 3)
intH = (19 * intA + intB - intD - intG + 15) Mod 30
intI = Int(intC / 4)
intK = intC Mod 4
intL = (32 + 2 * intE + 2 * intI - intH - intK) Mod 7
intM = Int((intA + 11 * intH + 22 * intL) / 451)
intN = Int((intH + intL - 7 * intM + 114) / 31)
intP = (intH + intL - 7 * intM + 114) Mod 31
Ostersonntag = DateSerial(Jahr, intN, intP + 1)
End Select
End Function
Gruß Jürgen
AW: Da war noch ein kleiner Fehler drin!
B4u
Hi Backowe,
danke für deine großartige Mühe. Ich werde es heute abend ausprobieren und gebe dir auf alle Fälle ein Feedback.
Herzlichen Grüße
AW: Da war noch ein kleiner Fehler drin!
B4u
Jetzt sitze ich zu Hause und schaue wie das Schwein ins Uhrwerk, denn ich weiß überhaupt nicht, wie ich das in mein Projekt einbaue. :-(
Hi,
da ich Dein Projekt nicht kenne und aus dem Beispiel von Dir ist auch nicht viel abzuleiten, kann ich nicht viel dazu sagen.
| VBA-Code: | Sub KrankTageImBlauenTeil()
Dim i As Integer, n As Integer, AnzMon As Integer
n = 9
AnzMon = DateDiff("m", Range("H4"), Range("I4")) + 1
Range("A9:F" & Cells(8, "A").End(xlDown).Row).ClearContents
For i = 1 To AnzMon
If Range("I4") < DateSerial(Year(Range("H4")), Month(Range("H4")) + 1, 1) - 1 Then
Cells(n, "A") = "Schmidt"
Cells(n, "B") = Range("H4")
Cells(n, "C") = Range("I4")
Cells(n, "D") = Format(Range("H4"), "MMMM")
Cells(n, "E") = Format(Range("H4"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(i + 8, "B"), Cells(i + 8, "C"))
Exit For
ElseIf i = 1 Then
Cells(n, "A") = "Schmidt" '<-- damit ein Name da steht ;o)
Cells(n, "B") = Range("H4")
Cells(n, "C") = DateSerial(Year(Range("H4")), Month(Range("H4")) + 1, 1) - 1
Cells(n, "D") = Format(Range("H4"), "MMMM")
Cells(n, "E") = Format(Range("H4"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(i + 8, "B"), Cells(i + 8, "C"))
ElseIf i > 1 And i < AnzMon Then
Cells(n, "A") = "Schmidt"
Cells(n, "B") = DateSerial(Year(Cells(n - 1, "B")), Month(Cells(n - 1, "B")) + 1, 1)
Cells(n, "C") = DateSerial(Year(Cells(n, "B")), Month(Cells(n, "B")) + 1, 1) - 1
Cells(n, "D") = Format(Cells(n, "B"), "MMMM")
Cells(n, "E") = Format(Cells(n, "C"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(n, "B"), Cells(n, "C"))
ElseIf i = AnzMon Then
Cells(n, "A") = "Schmidt"
Cells(n, "B") = DateSerial(Year(Cells(n - 1, "B")), Month(Cells(n - 1, "B")) + 1, 1)
Cells(n, "C") = Range("I4")
Cells(n, "D") = Format(Cells(n, "B"), "MMMM")
Cells(n, "E") = Format(Cells(n, "C"), "YYYY")
Cells(n, "F") = NettoArbTage(Cells(n, "B"), Cells(n, "C"))
End If
n = n + 1
Next
End Sub
Public Function NettoArbTage(Beginn As Date, Ende As Date, Optional ArbeitsTage As Range, Optional FreieTage As Range)
'Berechnung NettoArbeitstage mit Berücksichtigung der Feiertage + optional zusätzliche ArbeitsTage
'und / oder zusätzliche freie Tage!
Application.Volatile
If IsDate(Beginn) And IsDate(Ende) And Beginn < Ende Then
Do While Beginn <= Ende
If ArbeitsTage Is Nothing And FreieTage Is Nothing Then
If ATag(Beginn) = 1 Then
NettoArbTage = NettoArbTage + 1
End If
ElseIf ArbeitsTage Is Nothing Then
If ATag(Beginn) = 1 And Application.IsNumber(Application.Match(CLng(Beginn), FreieTage, 0)) = False Then
NettoArbTage = NettoArbTage + 1
End If
ElseIf FreieTage Is Nothing Then
If ATag(Beginn) = 1 Or Application.IsNumber(Application.Match(CLng(Beginn), ArbeitsTage, 0)) Then
NettoArbTage = NettoArbTage + 1
End If
Else
If ATag(Beginn) = 1 And Application.IsNumber(Application.Match(CLng(Beginn), FreieTage, 0)) = False _
Or Application.IsNumber(Application.Match(CLng(Beginn), ArbeitsTage, 0)) Then
NettoArbTage = NettoArbTage + 1
End If
End If
Beginn = Beginn + 1
Loop
Else
NettoArbTage = 0
End If
End Function
Public Function ATag(Datum As Date) As Integer
'***********************************************************
'* !!! Achtung saarländische Feiertage, bitte anpassen !!! *
'***********************************************************
Dim Feiertage(12) As Date
Dim Jahr%, WTag%, i%
Jahr = CInt(Format(Datum, "yyyy"))
WTag = CInt(Weekday(Datum, 2))
ATag = 1
If WTag > 5 Then
ATag = 0 ' Wochenende
Else
Feiertage(0) = (Ostersonntag(Jahr)) - 2 ' Karfreitag
Feiertage(1) = (Ostersonntag(Jahr)) + 1 ' Ostermontag
Feiertage(2) = (Ostersonntag(Jahr)) + 39 ' Christi Himmelfahrt
Feiertage(3) = (Ostersonntag(Jahr)) + 50 ' Pfingstmontag
Feiertage(4) = (Ostersonntag(Jahr)) + 60 ' Fronleichnam
Feiertage(5) = CDate("01.01." & Jahr) ' Neujahr
Feiertage(6) = CDate("01.05." & Jahr) ' 1.Mai
Feiertage(7) = CDate("15.08." & Jahr) ' Maria Himmelfahrt
If Jahr < 1990 Then
Feiertage(8) = CDate("17.06." & Jahr) ' Tag der deutschen Einheit
Else
Feiertage(8) = CDate("03.10." & Jahr)
End If
Feiertage(9) = CDate("01.11." & Jahr) ' Allerheiligen
Feiertage(10) = CDate("25.12." & Jahr) ' 1. Weihnachtstag
Feiertage(11) = CDate("26.12." & Jahr) ' 2.Weihnachtstag
' Ist das Datum ein Feiertag?
For i = 0 To 11
If Datum = Feiertage(i) Then
ATag = 0
Exit For
End If
Next i
End If
End Function
Public Function Ostersonntag(Jahr As Integer) As Date
Dim intA As Integer, intB As Integer, intC As Integer, intD As Integer
Dim intE As Integer, intF As Integer, intG As Integer, intH As Integer
Dim intI As Integer, intK As Integer, intL As Integer, intM As Integer
Dim intN As Integer, intP As Integer
Application.Volatile
Select Case Jahr
Case Is >= 1900
intA = Jahr Mod 19
intB = Int(Jahr / 100)
intC = Jahr Mod 100
intD = Int(intB / 4)
intE = intB Mod 4
intF = Int((intB + 8) / 25)
intG = Int((intB - intF + 1) / 3)
intH = (19 * intA + intB - intD - intG + 15) Mod 30
intI = Int(intC / 4)
intK = intC Mod 4
intL = (32 + 2 * intE + 2 * intI - intH - intK) Mod 7
intM = Int((intA + 11 * intH + 22 * intL) / 451)
intN = Int((intH + intL - 7 * intM + 114) / 31)
intP = (intH + intL - 7 * intM + 114) Mod 31
Ostersonntag = DateSerial(Jahr, intN, intP + 1)
End Select
End Function
Gruß Jürgen
Darf ich es dir denn schicken? Schick mir ne Mail an antwort-all@gmx.de (Die kann ich hier getrost veröffentlichen.) Ich antworte dir gern auf meine reguläre.
Grins. Ich versuche es dann auch zu verstehen. Du rettest aber 4 Studenten ;-)
|
|
|