Supportnet / Forum / Tabellenkalkulation
VBA Kalender ohne Feiertage und Wochenenden
Frage
Hi Leute!
Folgendes Problem,ich habe zwei DTPicker, in dem einen steht das Anfangsdatum in dem anderen das Enddatum. Das Datum wird dann in B10, C10, D10 usw. eingetragen. Mein Problem ist das Feiertage bzw. Wochenenden überspringer werden müssen. Hat irgendwer diesbezüglich eine Idee?
Gruß AF
Antwort 1 von Saarbauer
Hallo,
da die Angaben etwas mager sind, nur ein grundsätzliche Anmerkung. Dein Problem ist für die Wochenende unter nutzung der Funktion Wochentag() lösbar, aber bei den Feiertagen wird es schwieriger, da diese entsprechend erfass werden müssen. Für feste Feiertage kein grösseres Problem. Ausserdem sind regionlae Feiertage zusätzlich zu beachten.
Könntest vielleicht eine Beispieldatei hier einstellen
http://www.netupload.de/
und Link hier hinterlegen
Gruß
Helmut
da die Angaben etwas mager sind, nur ein grundsätzliche Anmerkung. Dein Problem ist für die Wochenende unter nutzung der Funktion Wochentag() lösbar, aber bei den Feiertagen wird es schwieriger, da diese entsprechend erfass werden müssen. Für feste Feiertage kein grösseres Problem. Ausserdem sind regionlae Feiertage zusätzlich zu beachten.
Könntest vielleicht eine Beispieldatei hier einstellen
http://www.netupload.de/
und Link hier hinterlegen
Gruß
Helmut
Antwort 2 von VBA_Anfänger
Hi,
kann die Datei leider aus Sicherheitsgründen nicht hochladen.
Mein Code schaut bis jetzt folgendermaßen aus.
Public Sub wert()
Dim i As Long
Dim e As Integer
Dim n As Long
Dim d As String
Dim names As String
Dim tabelle1 As String
tabelle1 = Cells(3, 1).Value
ActiveWorkbook.Sheets(tabelle1).Activate
For e = 11 To 200 Step 1
If Cells(e, 1) = Empty Then
Exit For
End If
Next e
´e = ActiveSheet.Cells(6, 1).Value
e = e - 1
´ComboBox1.Value = Empty
i = ComboBox1.Value
a = 1
For b = 11 To e Step 1
j = ActiveSheet.Cells(b, a).Value
If i = j Then
ActiveSheet.Cells(b, a).Select
Exit For
End If
Next b
t1 = DTPicker1.Value
t2 = DTPicker2.Value
ActiveSheet.Range("B10:IV10").Clear
For z = 3 To 60 Step 1
t = ActiveSheet.Cells(10, z).Value
tt = (t1 - t2)
If t = "" Then
ActiveSheet.Cells(10, 2).Select
ActiveSheet.Cells(10, 2) = t1
t3 = tt + 2
Exit For
End If
Next z
For t4 = 3 To t3 Step 1
If t4 <> t3 Then
t1 = t1 - 1
ActiveSheet.Cells(10, t4).Select
ActiveSheet.Cells(10, t4) = t1
End If
´Exit For
Next t4
t4 = t4 - 1
ActiveSheet.Cells(10, t4).Select
ActiveSheet.Cells(10, t4) = t2
For sp = 2 To 255 Step 1
If Cells(10, sp) = Empty Then
Exit For
End If
Next sp
adr = Cells(10, sp).Address
If sp > 26 Then
adr = Mid(adr, 2, 2)
Else
adr = Mid(adr, 2, 1)
End If
ActiveSheet.Range(adr & "10:IV" & e).Clear
´sp = endspalte
s = Charts.Count
For s = s To 50
If Charts.Count = 0 Then
Exit For
End If
Application.DisplayAlerts = False
Charts(s).Delete
Application.DisplayAlerts = True
Next s
d = adr
ActiveSheet.Cells(b, 1).Select
n = ActiveSheet.Cells(b, 1).Value
names = n
Charts.Add
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=Sheets(tabelle1).Range("B" & b & ":" & d & b), _
PlotBy:=xlRows
ActiveChart.SeriesCollection(1).XValues = Sheets(tabelle1).Range("B10:" & d & "10")
ActiveChart.SeriesCollection(1).Name = names
ActiveChart.Location Where:=xlLocationAsNewSheet
With ActiveChart
.HasAxis(xlCategory, xlPrimary) = True
.HasAxis(xlValue, xlPrimary) = True
End With
ActiveChart.Axes(xlCategory, xlPrimary).CategoryType = xlCategoryScale
With ActiveChart.Axes(xlCategory)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
With ActiveChart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
ActiveChart.HasLegend = False
m = Charts.Count
Charts(m).Select
Charts(m).Name = names
Sheets(names).Move after:=Sheets(tabelle1)
ActiveWorkbook.Sheets(tabelle1).Select
ActiveSheet.Cells(1, 1).Select
End Sub
Private Sub Ausführen_Click()
Call wert
End Sub
In A3 steht der Tabellname, in B5 bis D7 ist die Combobox über die die Nummer ausgewählt wird (A11 bis A87) und über die eine Grafik erstellt werden soll. In A11 bis A87 stehen die Nummern über die die Grafik erstellt werden soll und in B10,C10 steht das Datum. In Spalte B11 bis B87 werden jeden Tag neue Werte eingespielt und die alten verschieben sich nach C11 bis C87. Nachdem aber nur an Arbeitstagen Daten zur Verfügung stehen funktioniert das ganze leider nicht. Feiertage wären für uns Östereicher 26.10, 2.11,8.12,24.12,25.12, 26.12.
Vielleicht kannst du mir weiterhelfen.
Danke im Voraus
AF
kann die Datei leider aus Sicherheitsgründen nicht hochladen.
Mein Code schaut bis jetzt folgendermaßen aus.
Public Sub wert()
Dim i As Long
Dim e As Integer
Dim n As Long
Dim d As String
Dim names As String
Dim tabelle1 As String
tabelle1 = Cells(3, 1).Value
ActiveWorkbook.Sheets(tabelle1).Activate
For e = 11 To 200 Step 1
If Cells(e, 1) = Empty Then
Exit For
End If
Next e
´e = ActiveSheet.Cells(6, 1).Value
e = e - 1
´ComboBox1.Value = Empty
i = ComboBox1.Value
a = 1
For b = 11 To e Step 1
j = ActiveSheet.Cells(b, a).Value
If i = j Then
ActiveSheet.Cells(b, a).Select
Exit For
End If
Next b
t1 = DTPicker1.Value
t2 = DTPicker2.Value
ActiveSheet.Range("B10:IV10").Clear
For z = 3 To 60 Step 1
t = ActiveSheet.Cells(10, z).Value
tt = (t1 - t2)
If t = "" Then
ActiveSheet.Cells(10, 2).Select
ActiveSheet.Cells(10, 2) = t1
t3 = tt + 2
Exit For
End If
Next z
For t4 = 3 To t3 Step 1
If t4 <> t3 Then
t1 = t1 - 1
ActiveSheet.Cells(10, t4).Select
ActiveSheet.Cells(10, t4) = t1
End If
´Exit For
Next t4
t4 = t4 - 1
ActiveSheet.Cells(10, t4).Select
ActiveSheet.Cells(10, t4) = t2
For sp = 2 To 255 Step 1
If Cells(10, sp) = Empty Then
Exit For
End If
Next sp
adr = Cells(10, sp).Address
If sp > 26 Then
adr = Mid(adr, 2, 2)
Else
adr = Mid(adr, 2, 1)
End If
ActiveSheet.Range(adr & "10:IV" & e).Clear
´sp = endspalte
s = Charts.Count
For s = s To 50
If Charts.Count = 0 Then
Exit For
End If
Application.DisplayAlerts = False
Charts(s).Delete
Application.DisplayAlerts = True
Next s
d = adr
ActiveSheet.Cells(b, 1).Select
n = ActiveSheet.Cells(b, 1).Value
names = n
Charts.Add
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=Sheets(tabelle1).Range("B" & b & ":" & d & b), _
PlotBy:=xlRows
ActiveChart.SeriesCollection(1).XValues = Sheets(tabelle1).Range("B10:" & d & "10")
ActiveChart.SeriesCollection(1).Name = names
ActiveChart.Location Where:=xlLocationAsNewSheet
With ActiveChart
.HasAxis(xlCategory, xlPrimary) = True
.HasAxis(xlValue, xlPrimary) = True
End With
ActiveChart.Axes(xlCategory, xlPrimary).CategoryType = xlCategoryScale
With ActiveChart.Axes(xlCategory)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
With ActiveChart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
ActiveChart.HasLegend = False
m = Charts.Count
Charts(m).Select
Charts(m).Name = names
Sheets(names).Move after:=Sheets(tabelle1)
ActiveWorkbook.Sheets(tabelle1).Select
ActiveSheet.Cells(1, 1).Select
End Sub
Private Sub Ausführen_Click()
Call wert
End Sub
In A3 steht der Tabellname, in B5 bis D7 ist die Combobox über die die Nummer ausgewählt wird (A11 bis A87) und über die eine Grafik erstellt werden soll. In A11 bis A87 stehen die Nummern über die die Grafik erstellt werden soll und in B10,C10 steht das Datum. In Spalte B11 bis B87 werden jeden Tag neue Werte eingespielt und die alten verschieben sich nach C11 bis C87. Nachdem aber nur an Arbeitstagen Daten zur Verfügung stehen funktioniert das ganze leider nicht. Feiertage wären für uns Östereicher 26.10, 2.11,8.12,24.12,25.12, 26.12.
Vielleicht kannst du mir weiterhelfen.
Danke im Voraus
AF