01.09.2017, 16:59 (Dieser Beitrag wurde zuletzt bearbeitet: 02.09.2017, 06:22 von WillWissen.
Bearbeitungsgrund: Code in Codetags gesetzt
)
Hallo zusammen,
mein Kumpel hat ein Problem und ich konnte ihn auch nicht weiterhelfen.Hoffe das ihr eine Lösung findet:
Der Code:
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim lngC As Long, varRet As Variant On Error GoTo Errorhandler Select Case Sh.Name Case "Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember" Application.EnableEvents = False
If Not Intersect(Target, Range("F10:AJ94")) Is Nothing Then With Target(1, 1) lngC = Application.CountIfs(Range(Cells(10, 3), Cells(94, 3)), Cells(.Row, 3), Range(Cells(10, .Column), Cells(94, .Column)), "u") varRet = Application.Match(Cells(.Row, 3), Range("AT2:AT9"), 0) If IsNumeric(varRet) Then If lngC > Range("AT2:AT9").Cells(varRet, 1).Offset(0, 1) Then If MsgBox("Bitte Urlaubsvorgabe prüfen!" & vbLf & vbLf & _ "ACHTUNG!!! Urlaub wird trozdem eintragen", 308) = 7 Then
Application.Undo End If End If End If End With End If Case Else End Select Errorhandler: Application.EnableEvents = True
End Sub
In der Spalte AU, AW, AY, BA, BC stehen nach einer Vorgabe wieviel Mitarbeiter/je Gruppe Urlaub haben dürfen AT2: AU9 Der Code ist aber für das ganze Tabellenblatt F10:AJ94 . Kann man den Code irgendwie auf die KWs anpassen ? Das heißt: Im Januar in AW steht 2 drin, Bereich " Stapler KS "dann darf er in der Kalenderwoche 2 ( N10:R94 )nur 2 Mitarbeiter Urlaub vergeben werden, sonst kommt diese Meldung:
"Bitte Urlaubsvorgabe prüfen!"
"ACHTUNG!!! Urlaub wird trozdem eintragen"
Leider weiß ich nicht wie es geht
Ich müsste den Code jetzt in den einzelnen Tabellenblätter immer neu anpassen.
mich amüsiert das sich bis jetzt noch kein Kollege gemedet hat wg. Crossing.
Obwohl ich den Code Anfangs nicht verstanden gelang es mir ihn zu knacken, das Open für alle Monate Sheets(Monat).Select umzuschreiben, und den wahren Fehler zu finden. Jeder Versuch im Eingabefeld den Range Bereich einzugrenzen waere schlicht und einfach zwecklos gewesen!! Aber wo lag dieser "saudumme" Fehler???
Schaue dir bitte mal diese Zeile an, und erkenne was daran falsch ist !! Ich habe über eine Stunde gebraucht, auch mit Versuchen den KW Bereich einzugrenzen, um endlich den wahren Fehler zu finden. Hier liegt der Hund begraben: '** Range("AT2:AT9").Cells(varRet, 1).Offset(0, 1) Dieser Offset ist immer gleich !! Spalte AU!! Die KW wird dabei nicht berücksichtigt!
Ist das eine erfreuliche Nachricht?? Prüfe es aber bitte selbst nach ob ich da richtig liege .... Ich habe auch gelesen was ein anderer Ratgeber über den Monat Februar, Maerz geschrieben hat. Aus dem Thema halte ich mich erst mal raus, ich habe mich auf diesen grundsaetzlichen Fehler konzentriert.
mfg Gast 123
Code:
Private Sub Workbook_Open() Dim dat As String, Tag As String Dim test As Object dat = Format(Date, "mmmm")
On Error Resume Next 'mit Set Prüfen ob Monatsblatt existiert Set test = Sheets(dat) If Not test Is Nothing Then Sheets(dat).Select Range("F5").Select Else MsgBox "Tabelle " & dat & " existiert nicht!" End If
'aktuellen Tag als String ermitteln "01,12" Tag = Day(Date) 'Zahl als String! If Len(Tag) = 1 Then Tag = "0" & Tag
On Error Resume Next Selection.Resize(1, 31).Find(What:=Tag, After:=ActiveCell, LookIn:=xlValues _ , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False).Offset(5, 0).Activate End Sub
'Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Dim RaBereich As Range, RaZelle As Range 'Set RaBereich = Range("F8:AJ77") 'For Each RaZelle In Range(Target.Address) 'If Not Intersect(RaZelle, RaBereich) Is Nothing Then 'Select Case UCase(RaZelle.Value) 'Case "U" 'RaZelle.Interior.ColorIndex = 4 ' grün 'RaZelle.Font.ColorIndex = 1 ' schwarz 'Case "U½" 'RaZelle.Interior.ColorIndex = 4 ' grün 'RaZelle.Font.ColorIndex = 1 ' schwarz 'Case "S" 'RaZelle.Interior.ColorIndex = 16 ' grau 'RaZelle.Font.ColorIndex = 2 ' schwarz 'Case "S½" 'RaZelle.Interior.ColorIndex = 16 ' grau 'RaZelle.Font.ColorIndex = 1 ' schwarz 'Case "K" 'RaZelle.Interior.ColorIndex = 3 ' rot 'RaZelle.Font.ColorIndex = 1 ' schwarz 'Case "K½" 'RaZelle.Interior.ColorIndex = 3 ' rot 'RaZelle.Font.ColorIndex = 1 ' schwarz 'Case Else 'RaZelle.Interior.ColorIndex = 2 ' Keine 'End Select 'End If 'Next RaZelle 'Set RaBereich = Nothing 'End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim lngC As Long, varRet As Variant, KW As Variant, MtaMax As Integer
On Error GoTo Errorhandler
On Error Resume Next Select Case Sh.Name Case "Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember" Application.EnableEvents = False
If Not Intersect(Target, Range("F10:AJ94")) Is Nothing Then With Target(1, 1)
'Korrektur: 2.9.2017 Gast 123 'Mitarbeiter Max Wert über KW Zahl aus Bereich AU:BC laden
'Suche KW in Überschrift Zeile 4 (rückwaerts) For j = 0 To 31 KW = CLng(Cells(4, .Column).Offset(0, -j)) If Len(KW) > 0 Then Exit For Next j
'Mitarbeiter Max Wert aus Bereich AU:BC laden MtaMax = Range("AT2:AT9").Cells(varRet, 1).Offset(0, (KW - 1) * 2 + 1).Value
'der Fehler lag hier: da wird Max -immer- aus der Spalte AU geladen '** Range("AT2:AT9").Cells(varRet, 1).Offset(0, 1) Offset immer gleich !!
If IsNumeric(varRet) Then If lngC > MtaMax Then If MsgBox("Bitte Urlaubsvorgabe prüfen!" & vbLf & vbLf & _ "ACHTUNG!!! Urlaub wird trozdem eintragen", 308) = 7 Then
Application.Undo End If End If End If End With End If Case Else End Select
Errorhandler: Application.EnableEvents = True End Sub
es gibt einen Denkfehler im 1. Code (bitte nicht übernehmen)
weil ich das Programm im Monat Februar nicht testen konnte, da kommt sofort eine Eingabe Fehlermeldung, habe ich einen Denkfehler bei der KW ermittlung übersehen. Fiel mir aber gerade ein, darum bitte den unteren Code übernehmen!!
im Januar stimmt die KW Zahl von 1-5 als Offset! In den folgenden Monaten geht die KW Zahl aber bis 52 hoch! Ich kann aber keinen Offset von 52 Spalten machen, sondern muss es auf 8 Spalten umrechnen. Das neue Programm ermittelt auch die 1. KW Zahl im Monat und zieht diesen Wert KW1 von der ermittelten KW Zahl ab! Den Fehler habe ich gerade korrigiert.
Damit sollte das Programm auch in den folgenden Monaten richtig funktionieren. itte selbst testen ....
mfg Gast 123
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim KW As Variant, KW1 As Variant, MtaMax As Integer 'neu eingefügt Dim lngC As Long, varRet As Variant
On Error GoTo Errorhandler
On Error Resume Next Select Case Sh.Name Case "Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember" Application.EnableEvents = False
If Not Intersect(Target, Range("F10:AJ94")) Is Nothing Then With Target(1, 1)
'Korrektur: 2.9.2017 Gast 123 'Mitarbeiter Max Wert über KW Zahl aus Bereich AU:BC laden
'Suche KW + KW1 in Überschrift Zeile 4 (rückwaerts) For j = 0 To 31 If KW1 = Empty And Len(Cells(4, 6).Offset(0, j)) > 0 Then _ KW1 = CInt(Cells(4, 6).Offset(0, j)) KW = CInt(Cells(4, .Column + 1).Offset(0, -j)) If Len(KW) > 0 And KW1 > 0 Then Exit For Next j
'Mitarbeiter Max Wert aus Bereich AU:BC laden KW = (KW - KW1) * 2 'KW auf Offset 0-8 umrechnen MtaMax = Range("AT2:AT9").Cells(varRet, 1).Offset(0, KW + 1).Value
'der Fehler lag hier: da wird Max -immer- aus der Spalte AU geladen '** Range("AT2:AT9").Cells(varRet, 1).Offset(0, 1) Offset immer gleich !! If IsNumeric(varRet) Then If lngC > MtaMax Then If MsgBox("Bitte Urlaubsvorgabe prüfen!" & vbLf & vbLf & _ "ACHTUNG!!! Urlaub wird trozdem eintragen", 308) = 7 Then
Application.Undo End If End If End If End With End If Case Else End Select
Errorhandler: Application.EnableEvents = True End Sub
Hallo mir geht es eigentlich nicht um die anderen Codes, denn die laufen im Original Programm. Mir geht es darum wie ich die die einzelnen Zellenbereich anpassen kann.z.b
Und hier soll satt F10:AJ94 If Not Intersect(Target, Range("F10:AJ94")) Is Nothing Then With Target(1, 1) lngC = Application.CountIfs(Range(Cells(10, 3), Cells(94, 3)), Cells(.Row, 3), Range(Cells(10, .Column), Cells(94, .Column)), "u") varRet = Application.Match(Cells(.Row, 3), Range("AT2:AT9"), 0) If IsNumeric(varRet) Then If lngC > Range("AT2:AT9").Cells(varRet, 1).Offset(0, 1) Then If MsgBox("Bitte Urlaubsvorgabe prüfen!" & vbLf & vbLf & _ "ACHTUNG!!! Urlaub wird trozdem eintragen", 308) = 7 Then
Der Bereich N10:R94 weil das wäre KW2 und die Abfrage steht in Spalte AW drin. Der Nächste Bereich wäre U10:Y94 das wäre KW3 und die Abfrage steht in AY drin. usw...
ich habe eine Beispieldatei als .xlsx Datei hochgeladen. Weil viele Kollegen xlsm Dateien nicht öffnen sind alle Makros in den Tabellen vorhanden, wurden aber durch ein vorgestelltes " '* " Zeichen deaktiviert. Man braucht nur dieses Zeichen zu löschen dann sind die Makros wieder aktiviert!!
Ich Beispiel erscheinen nach einer Eingabe nacheinander zwei MsgBoxen mit dem Wert, der mit lngC verglichen wird, und der Zell Adresse aus der dieser Wert geladen wurde. Ich bitte zum Testen nacheinander in jeder KW beliebige Eingabe zu machen, um sich den Fehler in Ruhe anzuschauen. Dann erübrigt sich meines Erachtens auch das anpassen !!!
Gibt man in KW 5 einen beliebigen Wert ein sieht man an der 1. MsgBox das der Wert zum Vergleich mit lngC immer aus der Spalte AU geladen wird!! Das ist aber nur bei KW1 richtig, für KW5 müssste es die Spalte BC sein. Die Zeile ist richtig, aber nicht die Spalte!! Die anschliessend erscheinende MsgBox zeigt das beim neuen Code der richtige Wert aus der richtigen Spalte geladen wird.
Diese Prüfung bitte auch auf die übrigen Monate ausweiten. Weil im Beispiel Februar und Maerz nicht funktionierten konnte ich es dort nicht testen. Im neuen Code habe ich den Teil mit den MsgBoxen die zum Testen dienen durch eine Zeile markiert: '*********************** Der ganze Codeteil zwischen diesen Zeilen kann nach dem Test gelöscht werden. Ich bin auf die Rückmeldung gespannt ...
ich habe deine Datei heruntergeladen, bekomme aber eine Fehlermeldung beim Öffnen das mein Excel 2007 etwas nicht laden konnte. In der Datei fehlt auch das gesamte Makro im Blatt: Diese Arbeitsmappe. Ich habe es dann kopiert.
Was du offenbar im Augenblick nicht verstehst ist genau das woran ich über 1 Stunde gesucht habe!! Denn alle Versuche Bereich nach KW neu festzulegen schlugen alle fehl. Das hat mich so genervt das ich den Fehler per MsgBox analysierte, und ihm so endlich auf die Spur kam!! Diese MsgBox Methode war meine Fehler Analyse. Um dir das deutlich vor Augen zu führen benutze ich in dieser Demo Version 2 MsgBoxen!! Die erste Box zeigt dir welchen Wert und aus welcher Zelle dein altes Programm den Vergleichswert für lngC geladen hat. Es ist immer dieselbe Spalte, aus Zelle AU9 !! (bei StaplerA)
Deine echten Werte liegen aber je nach KW 1-5 für Januar in den Spalten: AU, AW, AY, BA, BC dort stehen: 1, 3 ,0 ,1 ,2 für StaplerA !! Wie kann das alte Programm einen -echten Vergleich- durchführen, wenn du immer für StaplerA den Wert 1 aus der Zelle AU9 holst??? Das stimmt ja nur für die 1. KW, aber nicht für die anderen KWs!! Erst mittels MsgBox, die mir die Zellen Adresse anzeigte erkannte ich diesen Fehler!!
Jetzt dürfte dir klar sein warum ich in der Zeile 4 nach der 1. KW und der KW für en aktuellen Tag suche. Die 1. KW im Monat benötige ich ja weil die KW Zahl von 1 bis 52 hoch geht! Ich brauche aber den exakten Offset (Versatz) auf die Spalten AU, AW, AY, BA, BC - die Zahl 52 für Dezember geht nicht!! Genau das zeigt die 2. MsgBox an, das ich jetzt für StaplerA die richtigen Werte aus der richtigen Spalte hole. Die Zell Adresse wird ja angezeigt!!
Test die Beispieldatei bitte noch einmal über alle 5 KW immer für StaplerA, und schaue ab wann die Fehlermeldung kommt, das kein Urlaub eingetragen werden kann. Mit dem neuen Makro sollte diese Meldung jetzt richtig kommen.
ich habe noch mal die KW Erstellung überarbeitet damit der Überschneidungs Fehler rauskommt. Anbei die geanderte Beispieldatei. In der Datei für 2017 sollte nur der untere Code Tiel geandert werden, dann müsste sie auch laufen. Ich habe gesehen das in 2018 eine neue Spalte dazu gekommen ist, halte das alte System mit Stapler A, B, usw. für effektiver, sinnvoller. Ich hatte auf StaplerA ja nur zum testen hingewiesen. Gut ist das du solche Dinge wie Spalten einschieben im Makro selbst aendern kannst.
Ich hoffe sehr das es jetzt fehlerfrei laeuft, will in Urlaub gehen. Bin dann für ~1 Monat im Forum nicht erreichbar.
mfg Gast 123
Code:
On Error Resume Next Select Case Sh.Name Case "Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember" If InStr(Target.Address, ":") Then Exit Sub 'Aussprung bei Bereich (z.B. löschen) If Target.Value = Empty Then Exit Sub 'Aussprung wenn Zelle leer, Eingabe gelöscht
Application.EnableEvents = False
If Not Intersect(Target, Range("F10:AJ94")) Is Nothing Then With Target(1, 1)
'Korrektur: 6.9.2017 Gast 123 'KW + KW1 (DIN) aus Datum ermitteln datum1 = Range("A1").Value 'Datum Korrekut Januar (KW 52) If Left(datum1, 6) = "01.01." Then datum1 = datum1 + 1 KW1 = DatePart("ww", datum1, vbMonday, vbFirstFourDays) datum = Cells(5, .Column).Value KW = DatePart("ww", datum, vbMonday, vbFirstFourDays)
