Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
408to412
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
408to412
408to412
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro Monatstag errechnen Schaltjahr

Makro Monatstag errechnen Schaltjahr
Sven
Hallo Hans und alle anderen,
ich habe letzte Woche schon einmal mein Problem kundgetan.
Es geht um eine Datei mit Makros, bei der ab dem Monat März die Tage mit dem Wochentag nicht mehr übereinstimmen.
Kann mir jemand helfen?
Vielen Dank im voraus.
An dieser Stelle auch noch einmal einen besonderen Dank an Hans, der versucht hat mir zu helfen. Der Versuch scheiterte aber leider (lag wohl an mir!)
Gruß
Sven
(Bekomme leider die Excel-Datei nicht geladen)

Sub MonatsnameErrechnen()
Select Case m
Case 1, 10:     x = 0
Case 2, 3, 11:  x = 3
Case 4, 7:      x = 6
Case 5:         x = 1
Case 6:         x = 4
Case 8:         x = 2
Case 9, 12:     x = 5
End Select
y = j - 1900
z = y + Int(y / 4) + x + t
' nun noch Schaltjahr ausschalten (wie witzig)
If (j / 4 = Int(j / 4) And j / 400 <> Int(j / 400)) Or j = 2000 And m < 3 Then z = z - 1
wota = z Mod 7
End Sub


Sub MonatszahlErrechnen()
Select Case m
Case 1, 3, 5, 7, 8, 10, 12: moza = 31
Case 4, 6, 9, 11: moza = 30
Case 2
moza = 28
If (j / 4 = Int(j / 4) And j / 400 <> Int(j / 400)) Or j = 2000 Then moza = 29
End Select
End Sub

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Makro Monatstag errechnen Schaltjahr
Nepumuk
Hallo Sven,
welche Daten hast du vorliegen und was willst du erreichen? Da in deinen Makros keinerlei Variablen deklariert sind und ich nicht raten will, was in m, j, x ... steht, kann ich diese nicht laufen lassen.
Gruß
Nepumuk
AW: Makro Monatstag errechnen Schaltjahr
Sven
So hier nun die komplette VBA:
und hier ist die dazugehörige Datei: https://www.herber.de/bbs/user/5065.xls
Beim ausführen des Makros "Wochentage eintragen" bekomme ich eine Fehlermeldung.
Bitte helft mir!
Dim t, m, j, wota, moza, arbbegmin, jmin, jstd, heutezelle, _
monatszahl, erstertag, monatsname, adr, adr1, adr2, Üstd

Sub test()
Application.OnSheetActivate = ActiveWorkbook.Name & _
"!Modul1.test3"
End Sub


Sub aaa()
Application.OnSheetActivate = ""
End Sub


Sub test3()
Sheets("formular").Select
WochentageEinfügen
End Sub


Sub MonatszahlausMonat()
With Worksheets("formular")
If .Range("G1").Value = "Jan" Then monatszahl = 1
If .Range("G1").Value = "Feb" Then monatszahl = 2
If .Range("G1").Value = "März" Then monatszahl = 3
If .Range("G1").Value = "April" Then monatszahl = 4
If .Range("G1").Value = "Mai" Then monatszahl = 5
If .Range("G1").Value = "Juni" Then monatszahl = 6
If .Range("G1").Value = "Juli" Then monatszahl = 7
If .Range("G1").Value = "Aug" Then monatszahl = 8
If .Range("G1").Value = "Sept" Then monatszahl = 9
If .Range("G1").Value = "Okt" Then monatszahl = 10
If .Range("G1").Value = "Nov" Then monatszahl = 11
If .Range("G1").Value = "Dez" Then monatszahl = 12
End With
End Sub


Sub WochentageEinfügen()
With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayWorkbookTabs = False
End With
With Application
.DisplayFormulaBar = False
.DisplayStatusBar = False
End With
Toolbars(1).Visible = False
Toolbars(2).Visible = False
Toolbars(7).Visible = False
With Application
.ShowToolTips = True
.LargeButtons = False
.ColorButtons = True
End With
MonatszahlausMonat
m = monatszahl
j = Worksheets("formular").Range("H1").Value
MonatszahlErrechnen
For i = 7 To 7 + 30
t = i - 6
Worksheets("formular").Unprotect
Worksheets("formular").Cells(i, 1).Font.ColorIndex = 1
If t <= moza Then
MonatsnameErrechnen
If wota = 6 Or wota = 0 Or Worksheets("Tabelle2").Cells(t, 8) = 3 _
Then Worksheets("formular").Cells(i, 1).Font.ColorIndex = 3
If t = Day(Date) And m = Month(Date) And Int(j) = Year(Date) Then _
Worksheets("formular").Cells(i, 1).Font.ColorIndex = 4: heutezelle = i
If wota = 1 Then Worksheets("formular").Cells(i, 1).Value = "Mo   " & i - 6 & "."
If wota = 2 Then Worksheets("formular").Cells(i, 1).Value = "Di   " & i - 6 & "."
If wota = 3 Then Worksheets("formular").Cells(i, 1).Value = "Mi   " & i - 6 & "."
If wota = 4 Then Worksheets("formular").Cells(i, 1).Value = "Do   " & i - 6 & "."
If wota = 5 Then Worksheets("formular").Cells(i, 1).Value = "Fr   " & i - 6 & "."
If wota = 6 Then Worksheets("formular").Cells(i, 1).Value = "Sa   " & i - 6 & "."
If wota = 0 Then Worksheets("formular").Cells(i, 1).Value = "So   " & i - 6 & "."
If i = 7 Then erstertag = wota
Else
Worksheets("formular").Cells(i, 1).Value = ""
End If
Next i
Worksheets("formular").DrawingObjects("WotaEintragen").Font.FontStyle = "standard"
Worksheets("formular").DrawingObjects("WotaEintragen").Font.ColorIndex = 1
Worksheets("formular").Protect
Worksheets("Tabelle2").Range("D1").Value = monatszahl
Worksheets("Tabelle2").Range("D2").Value = Worksheets("formular").Range("H1").Value
'z = MsgBox("Soll die Rahmenarbeitszeit auch übernommen werden?", 4)
'If z = 6 Then RahmenarbeitszeitÜbernehmen
'Worksheets("Tabelle2").Hide
End Sub


Sub DrehfeldMonat()
Worksheets("formular").Unprotect
z = Worksheets("formular").DrawingObjects("ÄndernMonat").Value
Select Case z
Case 1: Worksheets("formular").Range("G1").Value = "Jan"
Case 2: Worksheets("formular").Range("G1").Value = "Feb"
Case 3: Worksheets("formular").Range("G1").Value = "März"
Case 4: Worksheets("formular").Range("G1").Value = "April"
Case 5: Worksheets("formular").Range("G1").Value = "Mai"
Case 6: Worksheets("formular").Range("G1").Value = "Juni"
Case 7: Worksheets("formular").Range("G1").Value = "Juli"
Case 8: Worksheets("formular").Range("G1").Value = "Aug"
Case 9: Worksheets("formular").Range("G1").Value = "Sept"
Case 10: Worksheets("formular").Range("G1").Value = "Okt"
Case 11: Worksheets("formular").Range("G1").Value = "Nov"
Case 12: Worksheets("formular").Range("G1").Value = "Dez"
End Select
Worksheets("formular").DrawingObjects("WotaEintragen").Font.FontStyle = "Fett Kursiv"
Worksheets("formular").DrawingObjects("WotaEintragen").Font.ColorIndex = 3
If (Worksheets("Tabelle2").Range("D1").Value = z) And _
(Fix(Worksheets("Tabelle2").Range("D2").Value) = _
Fix(Worksheets("formular").Range("H1").Value)) Then
If Worksheets("tabelle2").Range("D3").Value = 1 Then
Worksheets("formular").DrawingObjects("Wochenzeit").Font.FontStyle = "standard"
Worksheets("formular").DrawingObjects("Wochenzeit").Font.ColorIndex = 1
End If
Else
Worksheets("formular").DrawingObjects("Wochenzeit").Font.FontStyle = "Fett Kursiv"
Worksheets("formular").DrawingObjects("Wochenzeit").Font.ColorIndex = 3
End If
Worksheets("formular").Protect
End Sub


Sub DrehfeldJahr()
Worksheets("formular").Unprotect
z = Worksheets("formular").DrawingObjects("ÄndernJahr").Value
Worksheets("formular").Range("H1").Value = z
Worksheets("formular").DrawingObjects("WotaEintragen").Font.FontStyle = "Fett Kursiv"
Worksheets("formular").DrawingObjects("WotaEintragen").Font.ColorIndex = 3
MonatszahlausMonat
If (Worksheets("Tabelle2").Range("D1").Value = monatszahl) And _
(Fix(Worksheets("Tabelle2").Range("D2").Value) = Fix(z)) Then
If Worksheets("tabelle2").Range("D3").Value = 1 Then
Worksheets("formular").DrawingObjects("Wochenzeit").Font.FontStyle = "standard"
Worksheets("formular").DrawingObjects("Wochenzeit").Font.ColorIndex = 1
End If
Else
Worksheets("formular").DrawingObjects("Wochenzeit").Font.FontStyle = "Fett Kursiv"
Worksheets("formular").DrawingObjects("Wochenzeit").Font.ColorIndex = 3
End If
Worksheets("formular").Protect
End Sub


Sub MonatsnameErrechnen()
Select Case m
Case 1, 10:     x = 0
Case 2, 3, 11:  x = 3
Case 4, 7:      x = 6
Case 5:         x = 1
Case 6:         x = 4
Case 8:         x = 2
Case 9, 12:     x = 5
End Select
y = j - 1900
z = y + Int(y / 4) + x + t
TAG(DATUM(B1;B2+1;0))
' nun noch Schaltjahr ausschalten (wie witzig)
If (j / 4 = Int(j / 4) And j / 400 <> Int(j / 400)) Or j = 2000 And m < 3 Then z = z - 1
wota = z Mod 7
End Sub


Sub MonatszahlErrechnen()
Select Case m
Case 1, 3, 5, 7, 8, 10, 12: moza = 31
Case 4, 6, 9, 11: moza = 30
Case 2
moza = 28
If (j / 4 = Int(j / 4) And j / 400 <> Int(j / 400)) Or j = 2000 Then moza = 29
End Select
End Sub


Sub ArbeitsbeginnEintragen()
q = False
MonatszahlausMonat
m = monatszahl
j = Worksheets("formular").Range("H1").Value
MonatszahlErrechnen
For i = 7 To 7 + 30
t = i - 6
If t <= moza Then
MonatsnameErrechnen
If t = Day(Date) And m = Month(Date) And Int(j) = Year(Date) Then _
heutezelle = i: q = True
End If
Next i
If Worksheets("Tabelle2").Cells(heutezelle - 6, 8).Value = 0 Then
If q Then
jstd = Hour(Now)
jmin = Minute(Now)
zeit = jstd & ":" & Right$("00" + jmin, 2)
DialogSheets("Arbeitsbeginn").TextBoxes("txtArbbegzeit").Text = zeit
DialogSheets("Arbeitsbeginn").TextBoxes("txtArbbegmin").Text _
= Worksheets("Tabelle2").Range("B1").Value
DialogSheets("Arbeitsbeginn").Show
Else
MsgBox ("Die Arbeitszeit kann nicht automatisch eingetragen" & _
Chr(13) & "werden, da das aktuelle Datum nicht auf dem aktiven" _
& Chr(13) & "Blatt zu finden ist!")
End If
Else
MsgBox ("Der Feldstatus dieses Tags muß erst auf ZEIT eingestellt werden!")
End If
End Sub


Sub SpinnerArbbeg()
z = 59 - DialogSheets("Arbeitsbeginn").DrawingObjects("spnArbbeg")
Worksheets("Tabelle2").Range("B1").Value = z
DialogSheets("Arbeitsbeginn").TextBoxes("txtArbbegmin").Text _
= Worksheets("Tabelle2").Range("B1").Value
End Sub


Sub ArbbegJa()
z = Worksheets("Tabelle2").Range("B1").Value
If jmin - z < 0 Then
jmin = 60 + (jmin - z): jstd = jstd - 1: If jstd < 0 Then jstd = 23
Else
jmin = jmin - z
End If
z = jstd & "," & Right$("00" + jmin, 2)
'MsgBox (heutezelle)
Worksheets("formular").Cells(heutezelle, 2).Value = z * 1
End Sub


Sub ArbeitsendeEintragen()
q = False
MonatszahlausMonat
m = monatszahl
j = Worksheets("formular").Range("H1").Value
MonatszahlErrechnen
For i = 7 To 7 + 30
t = i - 6
If t <= moza Then
MonatsnameErrechnen
If t = Day(Date) And m = Month(Date) And Int(j) = Year(Date) Then _
heutezelle = i: q = True
End If
Next i
If Worksheets("Tabelle2").Cells(heutezelle - 6, 8).Value = 0 Then
If q Then
jstd = Hour(Now)
jmin = Minute(Now)
zeit = jstd & ":" & Right$("00" + jmin, 2)
DialogSheets("Arbeitsende").TextBoxes("txtArbendezeit").Text = zeit
DialogSheets("Arbeitsende").TextBoxes("txtArbendemin").Text _
= Worksheets("Tabelle2").Range("B2").Value
DialogSheets("Arbeitsende").Show
Else
MsgBox ("Die Arbeitszeit kann nicht automatisch eingetragen" & _
Chr(13) & "werden, da das aktuelle Datum nicht auf dem aktiven" _
& Chr(13) & "Blatt zu finden ist!")
End If
Else
MsgBox ("Der Feldstatus dieses Tags muß erst auf ZEIT eingestellt werden!")
End If
End Sub


Sub SpinnerArbende()
z = 59 - DialogSheets("Arbeitsende").DrawingObjects("spnArbende")
Worksheets("Tabelle2").Range("B2").Value = z
DialogSheets("Arbeitsende").TextBoxes("txtArbendemin").Text _
= Worksheets("Tabelle2").Range("B2").Value
End Sub


Sub ArbendeJa()
z = Worksheets("Tabelle2").Range("B2").Value
If jmin + z > 59 Then
jmin = jmin + z - 60: jstd = jstd + 1: If jstd > 23 Then jstd = 0
Else
jmin = jmin + z
End If
z = jstd & "," & Right$("00" + jmin, 2)
'MsgBox (heutezelle)
Worksheets("formular").Cells(heutezelle, 4).Value = z * 1
End Sub


Sub Wochenzeit()
For i = 1 To 7
Worksheets("Tabelle2").Cells(i + 7, 3).Value = _
Worksheets("Tabelle2").Cells(i, 3).Value
Next i
DialogSheets("Wochenzeit").TextBoxes("txtwomo").Text _
= Worksheets("Tabelle2").Range("C1").Value / 10
DialogSheets("Wochenzeit").TextBoxes("txtwodi").Text _
= Worksheets("Tabelle2").Range("C2").Value / 10
DialogSheets("Wochenzeit").TextBoxes("txtwomi").Text _
= Worksheets("Tabelle2").Range("C3").Value / 10
DialogSheets("Wochenzeit").TextBoxes("txtwodo").Text _
= Worksheets("Tabelle2").Range("C4").Value / 10
DialogSheets("Wochenzeit").TextBoxes("txtwofr").Text _
= Worksheets("Tabelle2").Range("C5").Value / 10
DialogSheets("Wochenzeit").TextBoxes("txtwosa").Text _
= Worksheets("Tabelle2").Range("C6").Value / 10
DialogSheets("Wochenzeit").TextBoxes("txtwoso").Text _
= Worksheets("Tabelle2").Range("C7").Value / 10
DialogSheets("Wochenzeit").Show
Worksheets("Tabelle2").Range("D1").Value = monatszahl
Worksheets("Tabelle2").Range("D2").Value = Worksheets("formular").Range("H1").Value
Worksheets("tabelle2").Range("D3").Value = 1
End Sub


Sub spinnerwo1()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo1").Value
Worksheets("Tabelle2").Range("C1").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwomo").Text _
= Worksheets("Tabelle2").Range("C1").Value / 10
End Sub


Sub spinnerwo2()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo2")
Worksheets("Tabelle2").Range("C2").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwodi").Text _
= Worksheets("Tabelle2").Range("C2").Value / 10
End Sub


Sub spinnerwo3()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo3")
Worksheets("Tabelle2").Range("C3").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwomi").Text _
= Worksheets("Tabelle2").Range("C3").Value / 10
End Sub


Sub spinnerwo4()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo4")
Worksheets("Tabelle2").Range("C4").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwodo").Text _
= Worksheets("Tabelle2").Range("C4").Value / 10
End Sub


Sub spinnerwo5()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo5")
Worksheets("Tabelle2").Range("C5").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwofr").Text _
= Worksheets("Tabelle2").Range("C5").Value / 10
End Sub


Sub spinnerwo6()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo6")
Worksheets("Tabelle2").Range("C6").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwosa").Text _
= Worksheets("Tabelle2").Range("C6").Value / 10
End Sub


Sub spinnerwo7()
z = DialogSheets("Wochenzeit").DrawingObjects("spwo7")
Worksheets("Tabelle2").Range("C7").Value = z
DialogSheets("Wochenzeit").TextBoxes("txtwoso").Text _
= Worksheets("Tabelle2").Range("C7").Value / 10
End Sub


Sub woabbrechen()
For i = 1 To 7
Worksheets("Tabelle2").Cells(i, 3).Value = Worksheets("Tabelle2").Cells(i + 7, 3).Value
Next i
DialogSheets("Wochenzeit").Spinners("spwo1").Value _
= 239 - Worksheets("Tabelle2").Range("C1").Value
DialogSheets("Wochenzeit").Spinners("spwo2").Value _
= 239 - Worksheets("Tabelle2").Range("C2").Value
DialogSheets("Wochenzeit").Spinners("spwo3").Value _
= 239 - Worksheets("Tabelle2").Range("C3").Value
DialogSheets("Wochenzeit").Spinners("spwo4").Value _
= 239 - Worksheets("Tabelle2").Range("C4").Value
DialogSheets("Wochenzeit").Spinners("spwo5").Value _
= 239 - Worksheets("Tabelle2").Range("C5").Value
DialogSheets("Wochenzeit").Spinners("spwo6").Value _
= 239 - Worksheets("Tabelle2").Range("C6").Value
DialogSheets("Wochenzeit").Spinners("spwo7").Value _
= 239 - Worksheets("Tabelle2").Range("C7").Value
End Sub


Sub woeintragen()
MonatszahlausMonat
m = monatszahl
j = Worksheets("formular").Range("H1").Value
MonatszahlErrechnen
t = 1
MonatsnameErrechnen
x = wota
For i = 7 To 7 + 30
If x > 0 And Worksheets("formular").Cells(i, 1) <> Empty Then
Worksheets("formular").Cells(i, 10).Value = Worksheets("Tabelle2").Cells(x, 3).Value / 10
End If
x = x + 1
If x = 8 Then x = 1
Next i
Worksheets("formular").Unprotect
Worksheets("formular").DrawingObjects("Wochenzeit").Font.FontStyle = "standard"
Worksheets("formular").DrawingObjects("Wochenzeit").Font.ColorIndex = 1
Worksheets("formular").Protect
End Sub


Sub SollzeitspalteLöschen()
x = MsgBox("Wollen Sie die Sollzeit-Spalte" & Chr(13) & _
"wirklich löschen?" & Chr(13) & Chr(13) & "Kein Rückgängig!" _
& Chr(13), 260)
If x = 6 Then
For i = 7 To 7 + 30
Worksheets("formular").Cells(i, 10).Value = ""
Next i
Worksheets("formular").Unprotect
Worksheets("formular").DrawingObjects("Wochenzeit").Font.FontStyle = "Fett Kursiv"
Worksheets("formular").DrawingObjects("Wochenzeit").Font.ColorIndex = 3
Worksheets("formular").Protect
Worksheets("tabelle2").Range("d3") = 0
End If
End Sub


Sub Arbeitszeitspaltelöschen()
x = MsgBox("Wollen Sie die Spalten 'Arbeitsbeginn', 'Arbeitsende'" & Chr(13) & _
"und 'Fehlzeit' wirklich löschen?" & Chr(13) & _
"Der Feldstatus wird bei allen Tagen auf 'Zeit' gesetzt." _
& Chr(13) & Chr(13) & "Kein Rückgängig!" & Chr(13), 260)
If x = 6 Then
Worksheets("Formular").Unprotect
For i = 7 To 7 + 30
For j = 2 To 6 Step 2
Worksheets("Formular").Cells(i, j).Locked = False
Worksheets("formular").Cells(i, j).Value = ""
Next j
Worksheets("Formular").Cells(i, 2).NumberFormat = "0.00"
z = "B" & i
Worksheets("Formular").Cells(i, 3).Formula = _
"=int(" & z & ") +(int(((" & z & "-int(" & z & "))*100/6+0.001))/10)"
Worksheets("Formular").Cells(i, 8).Formula = _
"=IF(B" & i & ">0,IF(D" & i & ">B" & i & ",E" & i & "-C" & _
i & "-G" & i & ",),IF(G" & i & ">0,-G" & i & ",))"
If Worksheets("Tabelle2").Cells(i - 6, 8) = 3 Then
Worksheets("formular").Cells(i, 1).Font.ColorIndex = 1
End If
Worksheets("Tabelle2").Cells(i - 6, 8) = 0
Next i
Worksheets("formular").Protect
End If
End Sub


Sub druck()
Worksheets("formular").Unprotect
For j = 2 To 6 Step 2
For i = 7 To 7 + 30
Worksheets("Formular").Cells(i, j).Interior.ColorIndex = xlNone
Next i
Next j
For i = 7 To 7 + 30
Worksheets("Formular").Cells(i, 10).Interior.ColorIndex = xlNone
Next i
For i = 2 To 4
Worksheets("Formular").Cells(1, i).Interior.ColorIndex = xlNone
Next i
Sheets("Formular").Select
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1
For j = 2 To 6 Step 2
For i = 7 To 7 + 30
Worksheets("Formular").Cells(i, j).Interior.ColorIndex = 40
Next i
Next j
For i = 7 To 7 + 30
Worksheets("Formular").Cells(i, 10).Interior.ColorIndex = 40
Next i
For i = 2 To 4
Worksheets("Formular").Cells(1, i).Interior.ColorIndex = 40
Next i
Worksheets("formular").Protect
End Sub


Sub ende()
x = MsgBox("Soll das aktive Formular wirklich beendet werden?" & Chr(13) & _
"Es wird vorher gespeichert" _
& Chr(13), 4)
If x = 6 Then
'Application.OnSheetActivate = "!Modul1.test3"
Worksheets("formular").Unprotect
Worksheets("formular").DrawingObjects("WotaEintragen").Font.FontStyle = "Fett Kursiv"
Worksheets("formular").DrawingObjects("WotaEintragen").Font.ColorIndex = 3
Worksheets("formular").Protect
With ActiveWindow
.DisplayHorizontalScrollBar = True
.DisplayWorkbookTabs = True
End With
With Application
.DisplayFormulaBar = True
.DisplayStatusBar = True
End With
Toolbars(1).Visible = True
Toolbars(2).Visible = True
Toolbars(7).Visible = False
With Application
.ShowToolTips = True
.LargeButtons = False
.ColorButtons = True
End With
Worksheets("Tabelle2").Range("D1").Value = monatszahl
Worksheets("Tabelle2").Range("D2").Value = Worksheets("formular").Range("H1").Value
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End Sub


Sub statÜs()
adr = ActiveWindow.RangeSelection.Address
'MsgBox (adr)
If Len(adr) <= 5 Then
adr1 = Right(Left(adr, 2), 1)
adr2 = Right(adr, Len(adr) - 3)
If adr1 = "B" And adr2 >= 7 And adr2 <= 37 Then
If Worksheets("Formular").Cells(adr2, 10).Value = 0 Then
MsgBox ("Der Status dieses Felds kann nicht geändert werden," & Chr$(13) & _
"da keine SOLLZEIT für diesen Tag eingetragen wurde!" & Chr$(13) & Chr$(13) & _
"Klicken Sie dazu auf 'Rahmenzeit festlegen' oder" & Chr$(13) & _
"geben Sie die Sollzeit für diesen Tag manuell ein!")
Else
x = Worksheets("Tabelle2").Cells(adr2 - 6, 8).Value
If x = 0 Then
DialogSheets("Status").TextBoxes("txtstat").Text = "Zeit"
End If
If x = 1 Then
DialogSheets("Status").TextBoxes("txtstat").Text = "krank"
End If
If x = 2 Then
DialogSheets("Status").TextBoxes("txtstat").Text = "Urlaub"
End If
If x = 3 Then
DialogSheets("Status").TextBoxes("txtstat").Text = "Feiertag"
End If
If x = 4 Then
DialogSheets("Status").TextBoxes("txtstat").Text = "ÜS Abbau"
End If
If x = 5 Then
DialogSheets("Status").TextBoxes("txtstat").Text = "Freier Text"
End If
DialogSheets("ÜStd").TextBoxes("txtÜstd").Text = _
Abs((Worksheets("Formular").Cells(adr2, 10).Value)) - 0.5
DialogSheets("ÜStd").DrawingObjects("spnÜstd").Value = _
Abs(((Worksheets("Formular").Cells(adr2, 10).Value)) - 0.5) * 10
w = Left(Worksheets("Formular").Cells(adr2, 1).Value, 2) & ", den" & _
Right(Worksheets("Formular").Cells(adr2, 1).Value, Len(Worksheets("Formular").Cells(adr2, 1).Value) - 3) & " " & _
Worksheets("Formular").Range("G1").Value & " " & _
Worksheets("Formular").Range("H1").Value
DialogSheets("Status").TextBoxes("txttag").Text = w
DialogSheets("Status").Show
End If
Else
MsgBox ("Klicken Sie in eine der Zellen 'Arbeitsbeginn'")
End If
Else
MsgBox ("Klicken Sie in EINE der Zellen 'Arbeitsbeginn'")
End If
End Sub



Sub Statuszeit()
Worksheets("formular").Unprotect
Worksheets("Formular").Cells(adr2, 2).NumberFormat = "0.00"
Worksheets("Formular").Cells(adr2, 2).Font.Size = 10
Worksheets("Formular").Cells(adr2, 2).Value = ""
Worksheets("Formular").Cells(adr2, 6).Value = ""
Worksheets("Formular").Cells(adr2, 2).Locked = False
Worksheets("Formular").Cells(adr2, 4).Locked = False
Worksheets("Formular").Cells(adr2, 6).Locked = False
z = adr1 & adr2
Worksheets("Formular").Cells(adr2, 3).Formula = _
"=int(" & z & ") +(int(((" & z & "-int(" & z & "))*100/6+0.001))/10)"
Worksheets("Formular").Cells(adr2, 8).Formula = _
"=IF(B" & adr2 & ">0,IF(D" & adr2 & ">B" & adr2 & ",E" & adr2 & "-C" & _
adr2 & "-G" & adr2 & ",),IF(G" & adr2 & ">0,-G" & adr2 & ",))"
Worksheets("formular").Cells(adr2, 1).Font.ColorIndex = 1
Worksheets("formular").Protect
Worksheets("Tabelle2").Cells(adr2 - 6, 8) = 0
KrankUrlaubchecken
End Sub


Sub Statusurlaub()
x = MsgBox("Wenn Sie das Feld auf 'Urlaub' stellen," & Chr(13) & _
"werden an diesem Tag evtl. eingetragene Arbeitszeiten gelöscht." & Chr(13) & Chr(13) _
& "Wollen Sie das wirklich?" & Chr(13), 260)
If x = 6 Then
Worksheets("formular").Unprotect
Worksheets("Formular").Cells(adr2, 2).Value = "Urlaub"
Worksheets("Formular").Cells(adr2, 2).Font.Size = 10
Worksheets("Formular").Cells(adr2, 8).Formula = _
"=IF(B" & adr2 & ">0,IF(D" & adr2 & ">B" & adr2 & ",E" & adr2 & "-C" & _
adr2 & "-G" & adr2 & ",),IF(G" & adr2 & ">0,-G" & adr2 & ",))"
Worksheets("Formular").Cells(adr2, 2).Locked = True
Worksheets("Formular").Cells(adr2, 4).Locked = True
Worksheets("Formular").Cells(adr2, 6).Locked = True
Worksheets("Formular").Cells(adr2, 3).Value = 0
Worksheets("Formular").Cells(adr2, 4).Value = ""
Worksheets("Formular").Cells(adr2, 6).Value = ""
Worksheets("formular").Cells(adr2, 1).Font.ColorIndex = 1
Worksheets("formular").Protect
Worksheets("Tabelle2").Cells(adr2 - 6, 8) = 2
KrankUrlaubchecken
End If ' x=6
DialogSheets("Status").Hide
End Sub


Sub Statuskrank()
x = MsgBox("Wenn Sie das Feld auf 'krank' stellen," & Chr(13) & _
"werden an diesem Tag evtl. eingetragene Arbeitszeiten gelöscht." & Chr(13) & Chr(13) _
& "Wollen Sie das wirklich?" & Chr(13), 260)
If x = 6 Then
Worksheets("formular").Unprotect
Worksheets("Formular").Cells(adr2, 2).Value = "krank"
Worksheets("Formular").Cells(adr2, 2).Font.Size = 10
Worksheets("Formular").Cells(adr2, 8).Formula = _
"=IF(B" & adr2 & ">0,IF(D" & adr2 & ">B" & adr2 & ",E" & adr2 & "-C" & _
adr2 & "-G" & adr2 & ",),IF(G" & adr2 & ">0,-G" & adr2 & ",))"
Worksheets("Formular").Cells(adr2, 2).Locked = True
Worksheets("Formular").Cells(adr2, 4).Locked = True
Worksheets("Formular").Cells(adr2, 6).Locked = True
Worksheets("Formular").Cells(adr2, 3).Value = 0
Worksheets("Formular").Cells(adr2, 4).Value = ""
Worksheets("Formular").Cells(adr2, 6).Value = ""
Worksheets("formular").Cells(adr2, 1).Font.ColorIndex = 1
Worksheets("formular").Protect
Worksheets("Tabelle2").Cells(adr2 - 6, 8) = 1
KrankUrlaubchecken
End If
DialogSheets("Status").Hide
End Sub


Sub Statusfeiertag()
x = MsgBox("Wenn Sie das Feld auf 'Feiertag' stellen," & Chr(13) & _
"werden an diesem Tag evtl. eingetragene Arbeitszeiten gelöscht." & Chr(13) & Chr(13) _
& "Wollen Sie das wirklich?" & Chr(13), 260)
If x = 6 Then
Worksheets("formular").Unprotect
Worksheets("Formular").Cells(adr2, 2).Value = "Feiertag"
Worksheets("Formular").Cells(adr2, 2).Font.Size = 10
Worksheets("Formular").Cells(adr2, 8).Formula = _
"=IF(B" & adr2 & ">0,IF(D" & adr2 & ">B" & adr2 & ",E" & adr2 & "-C" & _
adr2 & "-G" & adr2 & ",),IF(G" & adr2 & ">0,-G" & adr2 & ",))"
Worksheets("Formular").Cells(adr2, 2).Locked = True
Worksheets("Formular").Cells(adr2, 4).Locked = True
Worksheets("Formular").Cells(adr2, 6).Locked = True
Worksheets("Formular").Cells(adr2, 3).Value = 0
Worksheets("Formular").Cells(adr2, 4).Value = ""
Worksheets("Formular").Cells(adr2, 6).Value = ""
Worksheets("formular").Cells(adr2, 1).Font.ColorIndex = 3
Worksheets("formular").Protect
Worksheets("Tabelle2").Cells(adr2 - 6, 8) = 3
KrankUrlaubchecken
End If
DialogSheets("Status").Hide
End Sub


Sub statÜbstd()
DialogSheets("Status").Hide
DialogSheets("ÜStd").Show
End Sub


Sub Freitext()
y = 0
DialogSheets("Status").Hide
x = Application.InputBox("Geben Sie für diesen Tag einen freien Text" & Chr$(13) _
& "ein, z. B. 'geschwänzt' oder 'hitzefrei' o. ä." & Chr$(13) & _
"oder warum man sonst an diesem Tag nicht gearbeitet hat." & Chr$(13) & Chr$(13) & _
"Der Text darf nicht länger sein als ein kurzes Wort!", "Freitext eingeben", , , , , , 2)
If x <> False Then
Worksheets("formular").Unprotect
Worksheets("Formular").Cells(adr2, 2).Value = x
Worksheets("Formular").Cells(adr2, 2).Font.Size = 9
Worksheets("Formular").Cells(adr2, 8).Formula = _
"=IF(B" & adr2 & ">0,IF(D" & adr2 & ">B" & adr2 & ",E" & adr2 & "-C" & _
adr2 & "-G" & adr2 & ",),IF(G" & adr2 & ">0,-G" & adr2 & ",))"
Worksheets("Formular").Cells(adr2, 2).Locked = True
Worksheets("Formular").Cells(adr2, 4).Locked = True
Worksheets("Formular").Cells(adr2, 6).Locked = True
Worksheets("Formular").Cells(adr2, 3).Value = 0
Worksheets("Formular").Cells(adr2, 4).Value = ""
Worksheets("Formular").Cells(adr2, 6).Value = ""
Worksheets("formular").Protect
Worksheets("Tabelle2").Cells(adr2 - 6, 8) = 5
KrankUrlaubchecken
End If
End Sub


Sub StatusUeberstunden()
Worksheets("formular").Unprotect
y = DialogSheets("ÜStd").DrawingObjects("spnÜstd").Value / 10
y1 = Fix(y)
y2 = Abs(y) - y1
Worksheets("Formular").Cells(adr2, 6).Value = y1 + y2 * 0.6
Worksheets("Formular").Cells(adr2, 2).Value = "ÜS-Abbau"
Worksheets("Formular").Cells(adr2, 8).Formula = _
"=E" & adr2 & "-C" & adr2 & "-G" & adr2 & ""
Worksheets("Formular").Cells(adr2, 2).Locked = True
Worksheets("Formular").Cells(adr2, 4).Locked = True
Worksheets("Formular").Cells(adr2, 6).Locked = False
Worksheets("Formular").Cells(adr2, 3).Value = 0
Worksheets("Formular").Cells(adr2, 4).Value = ""
Worksheets("formular").Cells(adr2, 1).Font.ColorIndex = 1
Worksheets("formular").Protect
Worksheets("Tabelle2").Cells(adr2 - 6, 8) = 4
DialogSheets("ÜStd").Hide
KrankUrlaubchecken
End Sub


Sub Statusabbruch()
DialogSheets("Status").Hide
End Sub


Sub Nameeintragen()
y = Worksheets("Formular").Range("B1").Value
x = Application.InputBox("Geben Sie Ihren Namen ein:", "Name eingeben", y, , , , , 2)
If x <> False Then
Worksheets("formular").Unprotect
Worksheets("Formular").Range("B1").Value = x
Worksheets("formular").Protect
End If
End Sub


Sub statüstd()
z = DialogSheets("ÜStd").DrawingObjects("spnÜstd").Value
DialogSheets("ÜStd").TextBoxes("txtÜstd").Text = _
DialogSheets("ÜStd").DrawingObjects("spnÜstd").Value / 10
End Sub


Sub KrankUrlaubchecken()
x = 0
For i = 7 To 7 + 30
If Worksheets("formular").Cells(i, 2).Value = "Urlaub" Then x = x + 1
Next i
Worksheets("formular").Range("E43").Value = x
x = 0
For i = 7 To 7 + 30
If Worksheets("formular").Cells(i, 2).Value = "krank" Then x = x + 1
Next i
Worksheets("formular").Range("C43").Value = x
End Sub

Anzeige
AW: Makro Monatstag errechnen Schaltjahr
Nepumuk
Hallo Sven,
was an der Formel falsch ist, kann ich dir nicht sagen, aber die wird nicht benötigt, da es in VBA eine Lösung gibt:


Sub WochentageEinfügen()
  With ActiveWindow
    .DisplayHorizontalScrollBar = False
    .DisplayWorkbookTabs = False
  End With
  With Application
    .DisplayFormulaBar = False
    .DisplayStatusBar = False
  End With
  Toolbars(1).Visible = False
  Toolbars(2).Visible = False
  Toolbars(7).Visible = False
  With Application
    .ShowToolTips = True
    .LargeButtons = False
    .ColorButtons = True
  End With
  MonatszahlausMonat
  m = monatszahl
  j = Worksheets("formular").Range("H1").Value
  MonatszahlErrechnen
  For i = 7 To 7 + 30
    t = i - 6
    Worksheets("formular").Unprotect
    Worksheets("formular").Cells(i, 1).Font.ColorIndex = 1
    If t <= moza Then
'      MonatsnameErrechnen
      wota = Weekday(DateSerial(j, m, t), vbSunday) - 1
      If wota = 6 Or wota = 0 Or Worksheets("Tabelle2").Cells(t, 8) = 3 _
          Then Worksheets("formular").Cells(i, 1).Font.ColorIndex = 3
      If t = Day(Date) And m = Month(Date) And Int(j) = Year(Date) Then _
          Worksheets("formular").Cells(i, 1).Font.ColorIndex = 4: heutezelle = i
      If wota = 1 Then Worksheets("formular").Cells(i, 1).Value = "Mo   " & i - 6 & "."
      If wota = 2 Then Worksheets("formular").Cells(i, 1).Value = "Di   " & i - 6 & "."
      If wota = 3 Then Worksheets("formular").Cells(i, 1).Value = "Mi   " & i - 6 & "."
      If wota = 4 Then Worksheets("formular").Cells(i, 1).Value = "Do   " & i - 6 & "."
      If wota = 5 Then Worksheets("formular").Cells(i, 1).Value = "Fr   " & i - 6 & "."
      If wota = 6 Then Worksheets("formular").Cells(i, 1).Value = "Sa   " & i - 6 & "."
      If wota = 0 Then Worksheets("formular").Cells(i, 1).Value = "So   " & i - 6 & "."
      If i = 7 Then erstertag = wota
    Else
      Worksheets("formular").Cells(i, 1).Value = ""
    End If
    Next i
    Worksheets("formular").DrawingObjects("WotaEintragen").Font.FontStyle = "standard"
    Worksheets("formular").DrawingObjects("WotaEintragen").Font.ColorIndex = 1
    Worksheets("formular").Protect
    Worksheets("Tabelle2").Range("D1").Value = monatszahl
    Worksheets("Tabelle2").Range("D2").Value = Worksheets("formular").Range("H1").Value
  'z = MsgBox("Soll die Rahmenarbeitszeit auch übernommen werden?", 4)
  'If z = 6 Then RahmenarbeitszeitÜbernehmen
  'Worksheets("Tabelle2").Hide
End Sub


Gruß
Nepumuk
Anzeige
AW: Makro Monatstag errechnen Schaltjahr
08.04.2004 14:59:07
Sven
Hallo Nepumuk,
ich weiß nicht was genau Du geändert hast, aber es läuft und ich freue mich RIESIG :-)).
Vielen Dank für Deine Mühe und Hilfe.
Gruß
Sven
und natürlich ein frohes Osterfest!!!


AW: Makro Monatstag errechnen Schaltjahr
xXx
Hallo,
was machst du denn da Kompliziertes? Um den Tag eines Datums zu ermitteln brauchst du doch nichts zu rechnen!
Msgbox Format(Date,"DDDD")
Gruß aus'm Pott
Udo

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige