hi ich hab n problem der folgende vba code berechnet das verbleibenden Datum anhand der verbleibenden Arbeitstage bis zum start of production. leider berchnet er mir die lletzte zeile nicht nur bis H34 und nicht bis H35 ich bin schon seit 2 Tagen am schaun und finde nicht was ich ändern soll :-(
bitte helft mir
Public Enum eFeiertage
'Entfernung der Feiertage vom Ostersonntag
Aschermittwoch = -46
Karfreitag = -2
Ostersamstag = -1
Ostersonntag = 0
Ostermontag = 1
ChristiHimmelfahrt = 39
Brueckentag_ChristiHimmelfahrt = 40
Pfingstsonntag = 49
Pfingstmontag = 50
Fronleichnam = 60
Brueckentag_Fronleichnam = 61
End Enum
Function Neujahr(ByVal Jahr) As Date
Neujahr = "01.01." & Jahr
End Function
Function HeiligDreiKoenig(ByVal Jahr) As Date
HeiligDreiKoenig = "06.01." & Jahr
End Function
Function TagDerArbeit(ByVal Jahr) As Date
TagDerArbeit = "01.05." & Jahr
End Function
Function TagDerDeutschenEinheit(ByVal Jahr) As Date
TagDerDeutschenEinheit = "03.10." & Jahr
End Function
Function Allerheiligen(ByVal Jahr) As Date
Allerheiligen = "01.11." & Jahr
End Function
Function HeiligerAbend(ByVal Jahr) As Date
HeiligerAbend = "24.12." & Jahr
End Function
Function ErsterWeihnachtstag(ByVal Jahr) As Date
ErsterWeihnachtstag = "25.12." & Jahr
End Function
Function ZweiterWeihnachtstag(ByVal Jahr) As Date
ZweiterWeihnachtstag = "26.12." & Jahr
End Function
Function Silvester(ByVal Jahr) As Date
Silvester = "31.12." & Jahr
End Function
Function myKarfreitag(ByVal Jahr) As Date
myKarfreitag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Ostersonntag) - 2
End Function
Function myOstersamstag(ByVal Jahr) As Date
myOstersamstag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Ostersonntag) - 1
End Function
Function myOstersonntag(ByVal Jahr) As Date
myOstersonntag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Ostersonntag)
End Function
Function myOstermontag(ByVal Jahr) As Date
myOstermontag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Ostersonntag) + 1
End Function
Function myChristiHimmelfahrt(ByVal Jahr) As Date
myChristiHimmelfahrt = FeiertagDatum(intJahr:=Jahr, Feiertag:=ChristiHimmelfahrt)
End Function
Function myBrueckentag_ChristiHimmelfahrt(ByVal Jahr) As Date
myBrueckentag_ChristiHimmelfahrt = FeiertagDatum(intJahr:=Jahr, Feiertag:=Brueckentag_ChristiHimmelfahrt)
End Function
Function myPfingstsamstag(ByVal Jahr) As Date
myPfingstsamstag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Pfingstsonntag) - 1
End Function
Function myPfingstsonntag(ByVal Jahr) As Date
myPfingstsonntag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Pfingstsonntag)
End Function
Function myPfingstmontag(ByVal Jahr) As Date
myPfingstmontag = FeiertagDatum(intJahr:=Jahr, Feiertag:=Pfingstsonntag) + 1
End Function
Function myFronleichnam(ByVal Jahr) As Date
myFronleichnam = FeiertagDatum(intJahr:=Jahr, Feiertag:=Fronleichnam)
End Function
Function myBrueckentag_Fronleichnam(ByVal Jahr) As Date
myBrueckentag_Fronleichnam = FeiertagDatum(intJahr:=Jahr, Feiertag:=Fronleichnam) + 1
End Function
Function d0401(ByVal Jahr) As Date
d0401 = "04.01." & Jahr
End Function
Function d0501(ByVal Jahr) As Date
d0501 = "05.01." & Jahr
End Function
Function d2704(ByVal Jahr) As Date
d2704 = "27.04." & Jahr
End Function
Function d2804(ByVal Jahr) As Date
d2804 = "28.04." & Jahr
End Function
Function d2904(ByVal Jahr) As Date
d2904 = "29.04." & Jahr
End Function
Function d3004(ByVal Jahr) As Date
d3004 = "30.04." & Jahr
End Function
Function d0205(ByVal Jahr) As Date
d0205 = "02.05." & Jahr
End Function
Function d0305(ByVal Jahr) As Date
d0305 = "03.05." & Jahr
End Function
Function d0110(ByVal Jahr) As Date
d0110 = "01.10." & Jahr
End Function
Function d0210(ByVal Jahr) As Date
d0210 = "02.10." & Jahr
End Function
Function d3010(ByVal Jahr) As Date
d3010 = "30.10." & Jahr
End Function
Function d3110(ByVal Jahr) As Date
d3110 = "31.10." & Jahr
End Function
Function d2212(ByVal Jahr) As Date
d2212 = "22.12." & Jahr
End Function
Function d2312(ByVal Jahr) As Date
d2312 = "23.12." & Jahr
End Function
Function d2912(ByVal Jahr) As Date
d2912 = "29.12." & Jahr
End Function
Function d3012(ByVal Jahr) As Date
d3012 = "30.12." & Jahr
End Function
Function Einsatztermin_pruefen(ByVal Zeile As Integer, ByVal Spalte As Integer) As Date
Dim Endtermin As Date
Endtermin = ActiveWorkbook.ActiveSheet.Cells(Zeile, Spalte).Value
'Ermittlung des neuen Endtermins, falls dieser urspruenglich auf einen Tag fiel,
'der nicht als Arbeitstag zaehlt (zum Beispiel auf einen Feiertag, Brueckentag oder
'auf das Wochenende).
Select Case Endtermin
Case Neujahr(Year(Endtermin)), HeiligDreiKoenig(Year(Endtermin)), TagDerDeutschenEinheit(Year(Endtermin)), Allerheiligen(Year(Endtermin))
If (Weekday(Endtermin) = 6)) Then
Endtermin = Endtermin + 3
ElseIf (Weekday(Endtermin) = 4) Then
Endtermin = Endtermin + 5
ElseIf (Weekday(Endtermin) = 5) Then
Endtermin = Endtermin + 4
End If
Case ErsterWeihnachtstag(Year(Endtermin))
If (Weekday(Endtermin) 31 Then
OS = OS - 31
Monat = Monat + 1
End If
FeiertagDatum = DateSerial(X, Monat, OS)
'************************************* Ende Formel *************************************'
'Bewegliche Feiertage, die berechnet werden sollen.
Select Case Feiertag
Case eFeiertage.ChristiHimmelfahrt
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.ChristiHimmelfahrt)
Case eFeiertage.Brueckentag_ChristiHimmelfahrt
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Brueckentag_ChristiHimmelfahrt)
Case eFeiertage.Fronleichnam
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Fronleichnam)
Case eFeiertage.Brueckentag_Fronleichnam
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Brueckentag_Fronleichnam)
Case eFeiertage.Ostermontag
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Ostermontag)
Case eFeiertage.Ostersonntag
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Ostersonntag)
Case eFeiertage.Pfingstsonntag
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Pfingstsonntag)
Case eFeiertage.Pfingstmontag
FeiertagDatum = DateAdd("d", FeiertagDatum, eFeiertage.Pfingstmontag)
Case Else
End Select
End Function
Sub Datum_ueberpruefen()
'* Beginn der Variablendeklaration fuer die Methode "Datum_ueberpruefen_schnelle_Version()" *'
Dim Datum As Date
Dim Endtermin As Date
Dim Liste As Collection
Set Liste = New Collection
Dim ATage As Integer 'Dient zur Ermittlung, wie hoch die groesste Anzahl an Arbeitstagen ist
Dim AfoTermin(3) As Integer 'Spalte und Zeile fuer untere und obere Grenze
Dim AT(3) As Integer 'Spalte und Zeile fuer untere und obere Grenze
Dim Auftragstermin(1) As Integer 'Spalte und Zeile fuer eine Zelle
Dim Lieferung(1) As Integer 'Spalte und Zeile fuer eine Zelle
Dim rot_faerben(1) As Integer
Dim spezielleZellen As Collection 'Collections beginnen mit Index 1!
Set spezielleZellen = New Collection
'* Ende der Variablendeklaration fuer die Methode "Datum_ueberpruefen_schnelle_Version()" **'
'*********** Beginn Prototypen-Radsaetze-spezifische Daten fuer das Excel-Sheet ************'
AfoTermin(0) = 10 'Zeile 10
AfoTermin(1) = 7 'Spalte 7
AfoTermin(2) = 27 'Zeile 27
AfoTermin(3) = 7 'Spalte 7
AT(0) = 10 'Zeile 10
AT(1) = 6 'Spalte 6
AT(2) = 27 'Zeile 27
AT(3) = 6 'Spalte 6
Auftragstermin(0) = 4 'Zeile 4
Auftragstermin(1) = 2 'Spalte 2
Lieferung(0) = 28 'Zeile 28
Lieferung(1) = 7 'Spalte 7
rot_faerben(0) = 2 'Beginnend mit zweiter Spalte
rot_faerben(1) = 3 'Enden in dritter Spalte
'Prototypen-Radsaetze in Liste hinzufuegen
spezielleZellen.Add (AfoTermin)
spezielleZellen.Add (AT)
spezielleZellen.Add (Auftragstermin)
spezielleZellen.Add (Lieferung)
spezielleZellen.Add (rot_faerben)
'************* Ende Prototypen-Radsaetze-spezifische Daten fuer das Excel-Sheet ************'
'***************** Beginn Radsaetze-spezifische Daten fuer das Excel-Sheet *****************'
AfoTermin(0) = 8
AfoTermin(1) = 8
AfoTermin(2) = 33
AfoTermin(3) = 8
AT(0) = 8
AT(1) = 7
AT(2) = 33
AT(3) = 7
Auftragstermin(0) = 4
Auftragstermin(1) = 2
Lieferung(0) = 34
Lieferung(1) = 8
rot_faerben(0) = 2 'Beginnend mit zweiter Spalte
rot_faerben(1) = 3 'Enden in dritter Spalte
'Prototypen-Radsaetze in Liste hinzufuegen
spezielleZellen.Add (AfoTermin)
spezielleZellen.Add (AT)
spezielleZellen.Add (Auftragstermin)
spezielleZellen.Add (Lieferung)
spezielleZellen.Add (rot_faerben)
'***************** Ende Radsaetze-spezifische Daten fuer das Excel-Sheet ******************'
'*********************************** Beginn Auswahl ***************************************'
Auswahl = 2 'Eingabemöglichkeiten fuer die Variable Auswahl:
'1 fuer Prototypen-Radsaetze, 2 fuer Radsaetze
AfoTermin_Auswahl = spezielleZellen.Item(Auswahl * 5 - 4)
AT_Auswahl = spezielleZellen.Item(Auswahl * 5 - 3)
Auftragstermin_Auswahl = spezielleZellen.Item(Auswahl * 5 - 2)
Lieferung_Auswahl = spezielleZellen.Item(Auswahl * 5 - 1)
rot_faerben_Auswahl = spezielleZellen.Item(Auswahl * 5)
'************************************ Ende Auswahl **************************************'
'***************************** Beginn Endtermin ueberpruefen ****************************'
ActiveWorkbook.ActiveSheet.Cells(Auftragstermin_Auswahl(0), Auftragstermin_Auswahl(1)).Value = Einsatztermin_pruefen(Auftragstermin_Auswahl(0), Auftragstermin_Auswahl(1))
ActiveWorkbook.ActiveSheet.Cells(Lieferung_Auswahl(0), Lieferung_Auswahl(1)).Value = ActiveWorkbook.ActiveSheet.Cells(Auftragstermin_Auswahl(0), Auftragstermin_Auswahl(1)).Value
'****************************** Ende Endtermin ueberpruefen *****************************'
'*************** Beginn leere Zellen in Spalte "AT" auf "Null" zu setzen ****************'
For nZahl = AfoTermin_Auswahl(0) To Lieferung_Auswahl(0)
If (IsEmpty(ActiveWorkbook.ActiveSheet.Cells(nZahl, AT_Auswahl(1)).Value) = True) Then
ActiveWorkbook.ActiveSheet.Cells(nZahl, AfoTermin_Auswahl(1)).Value = Null
End If
Next nZahl
'**************** Ende leere Zellen in Spalte "AT" auf "Null" zu setzen *****************'
'****** Beginn hoechste Anzahl an Arbeitstagen aus Excel-Spalte "AT" zu ermitteln *******'
ATage = 0
For nZahl = AfoTermin_Auswahl(0) To AfoTermin_Auswahl(2)
If (ActiveWorkbook.ActiveSheet.Cells(nZahl, AT_Auswahl(1)).Value > ATage) Then
ATage = ActiveWorkbook.ActiveSheet.Cells(nZahl, AT_Auswahl(1)).Value
End If
Next nZahl
'****** Ende hoechste Anzahl an Arbeitstagen aus Excel-Spalte "AT" zu ermitteln *******'
'************** Beginn jeweiliges Datum zu den Arbeitstagen zu ermitteln **************'
Datum = ActiveWorkbook.ActiveSheet.Cells(Lieferung_Auswahl(0), Lieferung_Auswahl(1)).Value
Do
If (Arbeitstag(Datum) = True) Then
Liste.Add (Datum)
Datum = Datum - 1
ATage = ATage - 1
ElseIf (Arbeitstag(Datum) = False) Then
Datum = Datum - 1
End If
Loop While ATage >= 0
For nZahl = AfoTermin_Auswahl(0) To AfoTermin_Auswahl(2)
If (IsEmpty(ActiveWorkbook.ActiveSheet.Cells(nZahl, AT_Auswahl(1)).Value) = False) Then
Wert = ActiveWorkbook.ActiveSheet.Cells(nZahl, AT_Auswahl(1)).Value
ActiveWorkbook.ActiveSheet.Cells(nZahl, AfoTermin_Auswahl(1)).Value = Liste.Item(Wert + 1)
End If
Next nZahl
'************** Ende jeweiliges Datum zu den Arbeitstagen zu ermitteln **************'
End Sub
|