Was mache ich bloß falsch, kann mir jemand helfen?
bye
Nike
Public Clear_ÜS As Boolean, Kommentar As Boolean, Bewegung As Boolean, Berechnung As Boolean
Public ÜS_HochWert As String
Public letzteZelle As Range
Public Zelladresse As Variant
Dim InternBewegung As Boolean, Primaer As Boolean, NewMonth As Boolean
Dim Antwort As String
Dim l As Long
Dim PlusZelle As Range
Dim Anzahl As Integer
Dim letzterWert(0) As Variant
Public Sub CoBu_NeuerMonat_Click()
Dim Antwort As String, Abrechnen As String
Dim Stelle As Range
Dim V As Integer
For Each Stelle In Range("A11:A41")
If Stelle.Interior.ColorIndex = 3 Then
Stelle.Activate
Antwort = MsgBox("Am " & Cells(Stelle.Row, 2).Value & " sind nicht acht Stunden gearbeitet worden!" & Chr(13) & Chr(13) & "Ist das korrekt?", vbQuestion + vbYesNo, "NEUER MONAT ...")
If Antwort = vbYes Then
Stelle.Interior.ColorIndex = xlNone
Else: Exit Sub
End If
End If
Next Stelle
Antwort = Left(Application.ActivePrinter, Len(Application.ActivePrinter) - 1)
Antwort = MsgBox("Ist der Drucker " & Antwort & " angeschlossen und eingeschaltet?", vbYesNo + vbQuestion, "NEUER MONAT ...")
Cells(ActiveCell.Row, ActiveCell.Column).Activate
If Antwort = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set Stelle = Range("C11:D41").Find("+", LookIn:=xlValues, lookat:=xlPart) 'BIOTRONIK
If Not Stelle Is Nothing Then V = 2
Set Stelle = Range("E11:O41").Find("+", LookIn:=xlValues, lookat:=xlPart) 'andere Aufträge
If Not Stelle Is Nothing Then V = V + 3
Select Case V
Case 0
Abrechnen = MsgBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet.", vbInformation + vbOKCancel, "NEUER MONAT ...")
If Abrechnen = vbOK Then
ActiveWorkbook.ÜberstundenLöschen = 2
nachAusdruck
End If
Case 2
Do
Abrechnen = InputBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet." & Chr(13) & Chr(13) & "Wie soll die Abrechnung erfolgen?" & Chr(13) & Chr(13) & Chr(13) & "1 - Überstunden 'BIOTRONIK' abrechnen" & Chr(13) & Chr(13) & "2 - keine Überstunden abrechnen" & Chr(13) & Chr(13) & Chr(13), "NEUER MONAT ...")
Loop Until Abrechnen = "" Or Abrechnen = "1" Or Abrechnen = "2"
Select Case Abrechnen
Case ""
GoTo ExitMonat
Case "1"
ActiveWorkbook.ÜberstundenLöschen = 2
Case "2"
ActiveWorkbook.ÜberstundenLöschen = 4
ClearÜS
End Select
nachAusdruck
Case 3
Do
Abrechnen = InputBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet." & Chr(13) & Chr(13) & "Wie soll die Abrechnung erfolgen?" & Chr(13) & Chr(13) & Chr(13) & "1 - Überstunden 'andere Aufträge' abrechnen" & Chr(13) & Chr(13) & "2 - keine Überstunden abrechnen" & Chr(13) & Chr(13) & Chr(13), "NEUER MONAT ...")
Loop Until Abrechnen = "" Or Abrechnen = "1" Or Abrechnen = "2"
Select Case Abrechnen
Case ""
GoTo ExitMonat
Case "1"
ActiveWorkbook.ÜberstundenLöschen = 3
Case "2"
ActiveWorkbook.ÜberstundenLöschen = 4
ClearÜS
End Select
nachAusdruck
Case 5
Do
Abrechnen = InputBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet." & Chr(13) & Chr(13) & "Wie soll die Abrechnung erfolgen?" & Chr(13) & Chr(13) & Chr(13) & "1 - alle Überstunden abrechnen" & Chr(13) & Chr(13) & "2 - nur Überstunden 'BIOTRONIK' abrechnen" & Chr(13) & Chr(13) & "3 - nur Überstunden 'andere Aufträge' abrechnen" & Chr(13) & Chr(13) & "4 - keine Überstunden abrechnen" & Chr(13) & Chr(13) & Chr(13), "NEUER MONAT ...")
Loop Until Abrechnen = "" Or Abrechnen = "1" Or Abrechnen = "2" Or Abrechnen = "3" Or Abrechnen = "4"
Select Case Abrechnen
Case ""
GoTo ExitMonat
Case "1"
ActiveWorkbook.ÜberstundenLöschen = 1
Case "2"
ActiveWorkbook.ÜberstundenLöschen = 2
Case "3"
ActiveWorkbook.ÜberstundenLöschen = 3
Case "4"
ActiveWorkbook.ÜberstundenLöschen = 4
ClearÜS
End Select
nachAusdruck
End Select
ExitMonat:
Clear_ÜS = False
Range("C11").Activate
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Activate()
Set letzteZelle = ActiveCell
letzterWert(0) = ActiveCell.Value
letzteZelle.Activate
Berechnung = False
ThisWorkbook.ÜberstundenLöschen = 0
Kommentar = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim KSpalte As Integer, StellePlus As Integer, Urlaubszeile As Integer, KZeile As Integer, x As Integer
Dim Urlaubszelle As Range, UKommentar As Range
Dim Wort As String, Kommentartext As String
Dim KStelle As Range, Zelle As Range
Kommentar = False
If Clear_ÜS = True Or NewMonth = True Then Exit Sub
If letzteZelle.Column <> 8 Then
If Bewegung = True Then
Bewegung = False
ÜS_Eintrag
Kommentar = True
End If
If ActiveSheet.Name = "Stundenabrechnung" And (letzteZelle <> ActiveCell Or ActiveCell = "") Then
StellePlus = 0
StellePlus = InStr(1, letzterWert(0), "+")
If StellePlus <> 0 Then
Clear_ÜS = True
Application.ScreenUpdating = False
KZeile = letzteZelle.Row - 1
On Error Resume Next
letzteZelle.Comment.Delete
On Error GoTo 0
If letzteZelle.Column > 4 Then KSpalte = 9 Else KSpalte = 4
With Worksheets("Überstunden")
.Activate
Set KStelle = .Range(.Cells(KZeile, KSpalte), .Cells(KZeile, KSpalte + 2)).Find(CDbl(Right(letzterWert(0), Len(letzterWert(0)) - StellePlus)))
.Primaer = True
.Range(KStelle.Address).ClearContents
.Berechnen
End With
Worksheets("Stundenabrechnung").Activate
letzteZelle.Activate
Application.ScreenUpdating = True
Berechnen
Clear_ÜS = False
Exit Sub
End If
On Error Resume Next
Kommentartext = letzteZelle.Comment.Text
If Err.Number = 0 Then
If Left(Kommentartext, 4) = "Rest" Then
letzteZelle.Comment.Delete
With Worksheets("Urlaubstage")
For Each Urlaubszelle In .Range("A:A")
If Urlaubszelle = "" Then
Exit For
ElseIf Urlaubszelle = Format(Cells(ActiveCell.Row, 2), "dd.mm.yy") Then
If .Cells(Urlaubszelle.Row + 1, 1) = "" Then
Urlaubszelle.EntireRow.ClearContents
Else
Urlaubszelle.Delete Shift:=xlUp
Urlaubszeile = .Range("B:B").Find("").Row
.Cells(Urlaubszeile - 1, 1).EntireRow.ClearContents
End If
For Each UKommentar In Range(Cells(11, 3), Cells(41, 3))
Wort = Left(UKommentar.Comment.Text, 4)
If Wort = "Rest" Then
Wort = ""
Urlaubszeile = .Range("A:A").Find(Format(Cells(UKommentar.Row, 2), "dd.mm.yy")).Row
UKommentar.Comment.Text .Cells(Urlaubszeile, 2) & " " & .Cells(Urlaubszeile, 3) & ": " & .Cells(Urlaubszeile, 4) & " " & .Cells(Urlaubszeile, 5)
End If
Next UKommentar
Exit For
End If
Next Urlaubszelle
End With
Bereich_UnMerge
Exit Sub
ElseIf Left(Kommentartext, 4) = "acht" Then
Worksheets("Überstunden").Range("N9") = Worksheets("Überstunden").Range("N9").Value + 8
Worksheets("Überstunden").Berechnen
letzteZelle.ClearComments
Bereich_UnMerge
Exit Sub
Else 'Wert wurde mit ENTF gelöscht:
If letzteZelle.Address = ActiveCell.Address And ActiveCell.Text = "" Then
ActiveCell.Comment.Delete
Select Case letzterWert(0)
Case "frei", "Urlaub", "Feiertag", "krank"
letzteZelle.ClearComments
Bereich_UnMerge
Exit Sub
End Select
End If
End If
Else
Select Case letzterWert(0)
Case "frei", "Urlaub", "Feiertag", "krank"
Bereich_UnMerge
Exit Sub
Case "Sa", "So"
Clear_ÜS = True
Cells(letzteZelle.Row, 3) = letzterWert(0)
Clear_ÜS = False
End Select
End If
On Error GoTo 0
End If
If letzteZelle.Row > 5 Then
Select Case letzteZelle.Value
Case "So", "Sa"
Case "frei", "Urlaub", "Feiertag", "krank"
Application.DisplayAlerts = False
x = 0
For Each Zelle In Range(Cells(letzteZelle.Row, 3), Cells(letzteZelle.Row, 14))
If Zelle <> "" Then x = x + 1
Next Zelle
Clear_ÜS = True
If x > 1 Then
MsgBox "Für diesen Eintrag muss der Tag leer sein!", vbExclamation + vbOKOnly, "Falscher Eintrag"
letzteZelle.ClearContents
Else
Wort = letzteZelle.Text
Cells(letzteZelle.Row, letzteZelle.Column) = ""
Cells(letzteZelle.Row, 3) = Wort
Range(Cells(letzteZelle.Row, 3), Cells(letzteZelle.Row, 14)).Merge
Set letzteZelle = Cells(letzteZelle.Row, 3)
End If
Clear_ÜS = False
Application.DisplayAlerts = True
Case Else
If letzteZelle.Row = 6 Then Exit Sub
If letzteZelle = "" Then
Clear_ÜS = True
Berechnung = False
Berechnen
Primaer = False
Exit Sub
End If
Clear_ÜS = True
If IsNumeric(Left(letzteZelle.Text, 1)) <> True Then
letzteZelle = ""
MsgBox "Neben positiven Zahlenwerten kommen nur Begriffe wie frei (f), Urlaub (U), Feiertag (Fe) und krank (k) in Frage!", vbOKOnly + vbInformation, "Falscher Eintrag"
'Worksheets("Überstunden").UeSZelle.ClearContents 'deaktiviert am 14.10.02; verursacht einen Fehler, keine erkennbare Notwendigkeit
'Worksheets("Überstunden").Berechnen 'deaktiviert am 14.10.02; keine erkennbare Notwendigkeit
ElseIf Cells(6, letzteZelle.Column) = "" Then
letzteZelle = ""
MsgBox "Kein Projekt vorhanden!", vbOKOnly + vbExclamation, "Falscher Eintrag"
Else
Berechnung = False
Berechnen
End If
Clear_ÜS = False
End Select
End If
End If
If Berechnung = True Then
Berechnung = False
'Berechnen
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Private Sub Worksheet_Deactivate()
If Bewegung = True Then
If Range(Zelladresse) = letzteZelle Then
With Worksheets("Überstunden")
.Primaer = True
.Range(.UeAdresse).ClearContents
.Berechnen
MsgBox "Der Überstundenwert wurde keiner Arbeitszeit zugeordnet - Wert gelöscht!", vbOKOnly + vbInformation, "Überstundenupdate"
End With
End If
End If
ÜS_HochWert = ""
InternBewegung = False
Bewegung = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim Fehler As Boolean, Urlaub_ As Boolean
Dim Text_Kommentar As String, Zeitspanne As String, Kommentar_ As String
Dim RZe As Integer, Zeile As Integer
Dim Urlaubsjahr
Select Case ActiveCell.Row
Case 11 To 41
Range("B11:B41").Interior.ColorIndex = xlNone
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 15
Case 5
Cells(6, ActiveCell.Column).Activate
Case 42
Cells(41, ActiveCell.Column).Activate
End Select
Select Case ActiveCell.Column
Case Is < 3
Cells(ActiveCell.Row, 3).Activate
Case Is > 14
Cells(ActiveCell.Row, 14).Activate
End Select
If Bewegung = True Then
Range(Zelladresse).Activate
Set letzteZelle = Range(Zelladresse)
Exit Sub
End If
If letzteZelle.Column = 8 Then GoTo Sprung
If Kommentar = False Then
If Berechnung = False Then
Select Case letzteZelle
Case "Urlaub"
Urlaub_ = True
GoTo Urlaub
Case "frei", "Feiertag"
Kommentar = True
Cells(ActiveCell.Row, 2).Interior.ColorIndex = xlNone
letzteZelle.Activate
Antwort = InputBox("Kommentar:", Format(Cells(letzteZelle.Row, 2), "d. mmmm"), Text_Kommentar)
Fehler = True
GoTo Urlaubsantwort
End Select
If IsNumeric(Left(letzteZelle.Text, 1)) = True Then
Urlaub:
Kommentar = True
Cells(ActiveCell.Row, 2).Interior.ColorIndex = xlNone
letzteZelle.Activate
On Error Resume Next
Kommentar_ = letzteZelle.Comment.Text
If Err.Number <> 0 Then '(kein Kommentar)
Fehler = True
RZe = letzteZelle.Row
Do
On Error GoTo 0
On Error Resume Next
RZe = RZe - 1
Text_Kommentar = Cells(RZe, letzteZelle.Column).Comment.Text
Loop Until RZe = 10 Or Err.Number = 0
Else '(Kommentar vorhanden)
Text_Kommentar = Kommentar_
End If
On Error GoTo 0
If Urlaub_ = True And Fehler = True Then
If Worksheets("Überstunden").Range("N9").Value >= 8 Then
Antwort = MsgBox("Soll dieser Urlaubstag mit dafür bereits zurückgestellten Überstunden " & "verrechnet werden?", vbQuestion + vbYesNo, "Urlaubstag")
If Antwort = vbYes Then
With Worksheets("Überstunden")
.Range("N9") = .Range("N9").Value - 8
.Range("N41") = ""
.Berechnen
End With
Antwort = "acht bereits dafür zurückgestellte Überstunden als Urlaub verrechnet"
GoTo Urlaubsantwort
End If
End If
With Worksheets("Urlaubstage")
Zeile = .Range("A:A").Find("", lookat:=xlWhole).Row - 1
If Zeile > 2 Then
Anzahl = .Cells(Zeile, 4).Value
If Anzahl = 0 Then '(kein Tag mehr vorhanden)
Antwort = InputBox("Es ist kein weiterer Urlaubstag vom Jahr " & .Cells(Zeile, 3).Value & " vorhanden!" & Chr(13) & Chr(13) & Chr(13) & "1 - Urlaubstag wird als 'frei' eingetragen" & Chr(13) & Chr(13) & "2 - Urlaubstag ist der Erste für das Jahr " & .Cells(Zeile, 3).Value + 1 & Chr(13) & Chr(13), "Urlaubstage " & .Cells(Zeile, 3).Value)
Select Case Antwort
Case "1"
ActiveCell = "frei"
Antwort = InputBox("Kommentar:", Format(Cells(letzteZelle.Row, 2), "d. mmmm"), Text_Kommentar)
GoTo Urlaubsantwort
Case "2"
.Cells(Zeile + 1, 1) = Format(Cells(letzteZelle.Row, 2), "dd.mm.yy")
.Cells(Zeile + 1, 2) = "Rest"
.Cells(Zeile + 1, 3) = .Cells(Zeile, 3).Value + 1
.Cells(Zeile + 1, 4) = 23
.Cells(Zeile + 1, 5) = "Tage"
Antwort = "Rest " & .Cells(Zeile, 3).Value + 1 & ": 23 Tage"
GoTo Urlaubsantwort
Case Else
ActiveCell = ""
GoTo Ende
End Select
Else: Anzahl = Anzahl - 1
If Anzahl = 1 Then
Zeitspanne = " Tag"
Else: Zeitspanne = " Tage"
End If
Text_Kommentar = .Cells(Zeile, 2) & " " & .Cells(Zeile, 3) & ": " & Anzahl & Zeitspanne
End If
Urlaubsjahr = .Cells(Zeile, 3).Value
Else
Text_Kommentar = "Rest " & Format(Range("K3"), "YYYY") & ": 23 Tage"
Anzahl = 23
Zeitspanne = "Tage"
Urlaubsjahr = Format(Range("K3"), "YYYY")
End If
Antwort = MsgBox(Text_Kommentar, vbInformation + vbOKCancel, "Urlaub - " & Format(Cells(letzteZelle.Row, 2), "d. mmmm") & " - Kommentar")
If Antwort = vbCancel Then
Clear_ÜS = True
letzteZelle = ""
Bereich_UnMerge
Clear_ÜS = False
GoTo Sprung
Else
Antwort = Text_Kommentar
.Cells(Zeile + 1, 1) = Format(Cells(letzteZelle.Row, 2), "dd.mm.yy")
.Cells(Zeile + 1, 2) = "Rest"
.Cells(Zeile + 1, 3) = Urlaubsjahr
.Cells(Zeile + 1, 4) = Anzahl
.Cells(Zeile + 1, 5) = Trim(Zeitspanne)
End If
End With
Else
If IsNumeric(Left(letzteZelle.Text, 1)) = True Then
If Bewegung = True Then
InternBewegung = True
Bewegung = False
End If
Antwort = InputBox("Kommentar über Tätigkeit der " & letzteZelle.Value & " h:", Format(Cells(letzteZelle.Row, 2), "d. mmmm"), Text_Kommentar)
Else: GoTo Sprung
End If
End If
Urlaubsantwort:
If Antwort <> "" Then
With letzteZelle
If Fehler = False Then 'Kommentar schon vorhanden
If Antwort <> "" Then
.Comment.Text (Antwort)
Kommentargroesse
Else
.Comment.Delete
GoTo Ende
End If
Else
If Antwort <> "" Then
.AddComment.Text (Antwort)
Kommentargroesse
End If
End If
End With
Ende:
Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate 'um bei Blatt Überstunden neu zu berechnen
End If
End If
End If
End If
Sprung:
Set letzteZelle = ActiveCell
letzterWert(0) = ActiveCell.Value
Kommentar = False
Berechnung = True
End Sub
Public Sub Berechnen()
Dim Hochbetrag As Double, HochbetragBiotronik As Double, HochbetragAndere As Double
Dim BetragBiotronik As Double, BetragAndere As Double
Dim PlusPos As Integer, n As Integer
Dim Spaltenbetrag As Variant
Dim Zelle As Range
Application.Calculation = xlCalculationManual
Pieps
For n = 3 To 14
If n <> 8 Then
Spaltenbetrag = 0
Hochbetrag = 0
If Cells(6, n) <> "" Then
For Each Zelle In Range(Cells(11, n), Cells(41, n))
If IsNumeric(Left(Zelle.Text, 1)) = True Then
If InStr(Zelle.Text, "+") <> 0 Then
PlusPos = InStr(Zelle.Text, "+")
Spaltenbetrag = Spaltenbetrag + CDbl(Left(Zelle.Text, PlusPos - 1))
Hochbetrag = Hochbetrag + CDbl(Mid(Zelle.Text, PlusPos + 1, Len(Zelle.Text)))
Else: Spaltenbetrag = Spaltenbetrag + Zelle.Value
End If
End If
Next Zelle
End If
If Spaltenbetrag <> 0 And Hochbetrag <> 0 Then
If Cells(42, n) <> Spaltenbetrag & " +" & Hochbetrag Then
Cells(42, n) = Spaltenbetrag & " +" & Hochbetrag
Cells(42, n).Characters(Len(Str(Spaltenbetrag)) + 1).Font.Superscript = True
End If
ElseIf Spaltenbetrag <> 0 And Hochbetrag = 0 Then
If Cells(42, n) <> Spaltenbetrag Then
Cells(42, n) = Spaltenbetrag
End If
ElseIf Spaltenbetrag = 0 And Hochbetrag <> 0 Then
If Cells(42, n) <> "0 +" & Hochbetrag Then
Cells(42, n) = "0 +" & Hochbetrag
Cells(42, n).Characters(Len(Str(Spaltenbetrag)) + 1).Font.Superscript = True
End If
Else: If Cells(42, n) <> "" Then Cells(42, n).ClearContents
End If
Select Case n
Case 3 To 4
BetragBiotronik = BetragBiotronik + Spaltenbetrag
HochbetragBiotronik = HochbetragBiotronik + Hochbetrag
Case 5 To 14
BetragAndere = BetragAndere + Spaltenbetrag
HochbetragAndere = HochbetragAndere + Hochbetrag
End Select
End If
Next
If BetragAndere + BetragBiotronik <> 0 Or HochbetragBiotronik + HochbetragAndere <> 0 Then
If HochbetragBiotronik + HochbetragAndere <> 0 Then
Cells(43, 3) = BetragAndere + BetragBiotronik & " +" & HochbetragBiotronik + HochbetragAndere
Cells(43, 3).Characters(Len(Str(BetragAndere + BetragBiotronik)) + 1).Font.Superscript = True
Else
Cells(43, 3) = BetragAndere + BetragBiotronik
End If
Else: Cells(43, 3) = ""
End If
If BetragBiotronik <> 0 Or HochbetragBiotronik <> 0 Then
If HochbetragBiotronik <> 0 Then
Cells(43, 6) = BetragBiotronik & " +" & HochbetragBiotronik
Cells(43, 6).Characters(Len(Str(BetragBiotronik)) + 1).Font.Superscript = True
Else
Cells(43, 6) = BetragBiotronik
End If
Else: Cells(43, 6) = ""
End If
Clear_ÜS = False
If Worksheets("Überstunden").UeSAbrechnung = False And NewMonth = False Then AchtStundenTest
End Sub
Public Sub ÜS_Eintrag()
Dim Länge As Integer
Clear_ÜS = True
Länge = Len(letzteZelle.Text)
letzteZelle = letzteZelle & " +" & ÜS_HochWert
letzteZelle.Characters(Länge + 1).Font.Superscript = True
Clear_ÜS = False
End Sub
Public Sub Kommentargroesse()
With ActiveCell
.Comment.Visible = True
.Comment.Shape.Select
Selection.AutoSize = True
.Comment.Visible = False
End With
End Sub
Public Sub nachAusdruck()
Dim Zelle As Range
NewMonth = True
Worksheets("Überstunden").Activate 'um auf den Wert von ÜberstundenLöschen reagieren zu können
Worksheets("Stundenabrechnung").Activate
ActiveSheet.PrintOut From:=1, to:=1
Worksheets("Kommentare").Activate
Worksheets("Kommentare").PrintOut From:=1, to:=1
Worksheets("Stundenabrechnung").Activate
Range("K3") = DateAdd("m", 1, Range("K3"))
Range("C11:O42").ClearContents
Range("C11:O41").ClearComments
Cells(43, 3).ClearContents
Cells(43, 6).ClearContents
With Range("C11:N41")
.UnMerge
.Borders(xlInsideVertical).ColorIndex = xlAutomatic
End With
SpaltenLayoutEinstellen 11, 41
For Each Zelle In Range("C11:C41")
Range("C" & Zelle.Row & ":N" & Zelle.Row).Interior.ColorIndex = xlNone
Select Case WeekDay(Cells(Zelle.Row, 2))
Case 7
Zelle = "Sa"
Range("C" & Zelle.Row & ":N" & Zelle.Row).Interior.ColorIndex = 15
Case 1
Zelle = "So"
Range("C" & Zelle.Row & ":N" & Zelle.Row).Interior.ColorIndex = 15
End Select
Next Zelle
NewMonth = False
End Sub
Public Sub ClearÜS()
Clear_ÜS = True
With Range("C11:O43")
Set PlusZelle = .Find("+")
If Not PlusZelle Is Nothing Then
Do
PlusZelle = Left(PlusZelle, InStr(1, PlusZelle.Text, "+") - 2)
If PlusZelle.Text = "0" Then PlusZelle = ""
Set PlusZelle = .FindNext(PlusZelle)
Loop Until PlusZelle Is Nothing
End If
End With
End Sub
Public Sub Pieps()
Dim n As Integer
For n = 1 To 50000
Select Case n
Case 1, 50000
Beep
End Select
Next n
End Sub
Public Sub AchtStundenTest()
Dim AnzStu As Double
Dim n As Integer, m As Integer, y As Integer
For n = 11 To 41
AnzStu = 0
For m = 3 To 14
If m <> 8 Then
y = 0
Select Case Cells(n, m)
Case ""
Case "frei", "Feiertag", "Urlaub", "Sa", "So", "krank"
Exit For
Case Else
y = InStr(1, Cells(n, m).Text, "+")
If y <> 0 Then
AnzStu = AnzStu + CDbl(Left(Cells(n, m).Text, y - 1))
Else: AnzStu = AnzStu + CDbl(Cells(n, m).Text)
End If
End Select
End If
Next
Select Case AnzStu
Case 0, 8
Cells(n, 1).Interior.ColorIndex = xlNone
Case Else
Cells(n, 1).Interior.ColorIndex = 3
End Select
Next
End Sub
Public Sub Bereich_UnMerge()
Range(Cells(letzteZelle.Row, 3), Cells(letzteZelle.Row, 14)).UnMerge
SpaltenLayoutEinstellen letzteZelle.Row, letzteZelle.Row
Worksheets("Urlaubstage").Activate
Worksheets("Stundenabrechnung").Activate
Cells(letzteZelle.Row + 1, 3).Activate
End Sub
Public Sub SpaltenLayoutEinstellen(Zeile1 As Integer, Zeile2 As Integer)
With Range(Cells(Zeile1, 3), Cells(Zeile2, 4)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Range(Cells(Zeile1, 4), Cells(Zeile2, 5)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Range(Cells(Zeile1, 5), Cells(Zeile2, 7)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Range(Cells(Zeile1, 7), Cells(Zeile2, 8)).Borders(xlInsideVertical)
.LineStyle = xlDash
.Weight = xlThin
End With
With Range(Cells(Zeile1, 8), Cells(Zeile2, 9)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Range(Cells(Zeile1, 9), Cells(Zeile2, 14)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End Sub
bye
Nike
Schau mal hier rein:
https://www.herber.de/forum/archiv/56to60/t57372.htm
Bye
Nike
Schau mal hier rein:
https://www.herber.de/forum/archiv/56to60/t57372.htm
Bye
Nike
Bye
Nike
Public UpdateProjekt As VBProject
Public UpdateMappe As Workbook
Dim Block As VBComponent
Dim Ze As Long
Dim Antwort As String
Public Sub DoUpdate()
Dim AM As Workbook
Set UpdateMappe = Nothing
For Each AM In Workbooks
If InStr(1, AM.Name, "abrechnung") <> 0 Then
Antwort = MsgBox("Das Update mit Datei " & AM.Name & " durchführen?", vbQuestion + vbYesNoCancel, _
"Update von Monatsabrechnung")
Select Case Antwort
Case vbYes
Set UpdateMappe = AM
Exit For
Case vbCancel
Exit Sub
End Select
End If
Next AM
If UpdateMappe Is Nothing = True Then
MsgBox "Es wurde keine Arbeitsmappe für das Update gefunden.", vbInformation, "Update von Monatsabrechnung"
Exit Sub
End If
If UpdateMappe.VBProject.Protection = vbext_pp_locked Then
MsgBox "Update mit gesperrtem Projekt ist nicht möglich!", vbInformation, "Update von Monatsabrechnung"
Exit Sub
End If
If UpdateMappe.Saved = False Then
Antwort = MsgBox("Änderungen in Datei " & UpdateMappe.Name & " sind nicht gesichert!" & Chr(13) & Chr(13) & _
"Datei wird jetzt in " & UpdateMappe.Path & " gespeichert und das Update durchgeführt.", vbQuestion + vbOKCancel, _
"Update von Monatsabrechnung")
Select Case Antwort
Case vbOK
UpdateMappe.Save
Case vbCancel
Exit Sub
End Select
End If
DeleteCode
UpdateMappe.Save
If CopyCode = True Then
'UpdateMappe.Save
Else
'UpdateMappe.Close False
End If
End Sub
Private Sub DeleteCode()
For Each Block In UpdateMappe.VBProject.VBComponents
Block.CodeModule.DeleteLines 1, Block.CodeModule.CountOfLines
Next Block
End Sub
Private Function CopyCode() As Boolean
CopyCode = True
For Each Block In UpdateMappe.VBProject.VBComponents
On Error Resume Next
' Ze = UpdateProjekt.VBComponents(Block.Name).CodeModule.CountOfLines
' Block.CodeModule.AddFromString UpdateProjekt.VBComponents(Block.Name).CodeModule.Lines(1, Ze)
For Ze = 1 To UpdateProjekt.VBComponents(Block.Name).CodeModule.CountOfLines
DoEvents
Block.CodeModule.InsertLines Ze, UpdateProjekt.VBComponents(Block.Name).CodeModule.Lines(Ze, 1)
Next
If Err.Number <> 0 Then
MsgBox "Fehler " & Err.Number & " beim Update! Der Vorgang wird abgebrochen und die Datei " & _
UpdateMappe.Name & " geschlossen!", vbInformation, "Update von Monatsabrechnung"
CopyCode = False
Exit Function
End If
On Error GoTo 0
Next Block
End Function
Danke für den Link!
Muß aber nicht, wär halt nur einfach gut...
Bye
Nike
Kleiner Tip mit ...
Tilde begin Tilde
Code
Tilde end Tilde
...kannst du den Code automatisch formatieren lassen
Tilde entspricht dem Zeichen ~
Bye
Nike
CopyCode = True
For Each Block In UpdateMappe.VBProject.VBComponents
On Error Resume Next
With UpdateProjekt.VBComponents(Block.Name).CodeModule
Text = .Lines(1, .CountOfLines)
End With
With Block.CodeModule
.AddFromString Text
End With
If Err.Number <> 0 Then
MsgBox "Fehler " & Err.Number & " beim Update! Der Vorgang wird abgebrochen und die Datei " & _
UpdateMappe.Name & " geschlossen!", vbInformation, "Update von Monatsabrechnung"
CopyCode = False
Exit Function
End If
On Error GoTo 0
Next Block
End Function
~ end ~
Nur als Hinweis für die Zukunft ;-)
Bye
nike