Excel Eingaben erzwingen

Question

Hallo zusammen,

ich bin gerade dabei eine Auftragübersicht zu erstellen und muss die Eingabe in bestimmten Zellen per Drop Down (bereits über Gültigkeitsregeln erstellt) für bestimmte Zellen erzwingen. Nach einiger Recherche ist mir klar geworden das sowas nur mit vba makro realisierbar ist. Leider habe ich davon überhaupt keine große Ahnung. Vielleicht kann mir jemand dabei Helfen...

Folgendes:

Wenn in einer Reihe der Spalte C eine Auftragsnummer angelegt wurde, sollen die Eingaben in der gleichen Reihe ab der Spalte D bis W erzwungen werden. In der Spalte G und H wird ein Endtermin/Liefer KW per Kalender (Makro bereits vorhanden) ausgewählt. In eingen Zellen ist die Eingabe per Drop Down erstellt. In anderen wiederrum müssen werte eingegeben werden die begrenzt wurden.

Nach erfolgter Eingabe in C soll automatisch zur nächsten Zelle gesprungen werden um dort eine Eingabe zu machen. Ein verlassen der Zelle, wechsel des Tabellenblattes oder Schließen der Datei ist ohne vorherige Eingabe nicht möglich. Es soll ein Hinweisfenster erscheinen das erst ein Wert eingetragen werden muss und die jeweilige Zelle für die Eingabe immer markiert werden.

Nachdem alle Eingaben abgeschlossen wurden, kann man sich wieder frei in der Tabelle "bewegen". Wenn ein Wert in den besagten Zellen geändert wird soll gefragt werden ob die Änderung richtig ist und der alte sowie neue Wert angezeigt werden. Erst nach bestätigung kann der Wert geändert werden.

Eine Änderung des bereits eingegeben Datums muss begründet werden und de Begründung in einer Textbox eingegeben sowie angezeigt werden. Auch das Anfangsdatum sollte dann noch ersichtlich sein.

Eine Eingabe in den Spalten D bis W ist erst nach Eingabe der der Auftragsummer in Spalte C möglich.

Ich würde mich sehr freuen und wäre dankbar wenn mir an dieser Stelle jemand helfen und einen Ansatz liefern kann. Ich hoffe meine Vorstellungen sind überhaupt realisierbar... Ich muss für die Erstellung einer Statistik die richtigen Eingaben durch andere Mitarbeiter gewährleisten können.

Mit freundlichen Grüßen

Sebastian

Answer 1

Hallo Sebastian,

"das sind ja gleich 3 Wünsche auf Einmal" :-)
Mal sehen ob ich dich ich dich richtig verstanden habe:
Öffne den VBA-Editor (Alt + F11) und füge in das Tabellenmodul das deine Datenbank enthält folgenden Code ein:

Private myReturnDirection As XlDirection
Private myMove As Boolean
Private myOldRange As Range
Private myOldValues As Variant

Public Sub Worksheet_Activate()

'Nach erfolgter Eingabe in C soll automatisch zur nächsten Zelle
'gesprungen werden um dort eine Eingabe zu machen. - Nur für dieses Sheet gültig
'Speichern der Nutzereinstellungen
myMove = Application.MoveAfterReturn
myReturnDirection = Application.MoveAfterReturnDirection
'Eingabetaste = Sprung nach rechts
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlToRight

Set myOldRange = Me.UsedRange
myOldValues = myOldRange

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)


'Eine Eingabe in den Spalten D bis W ist erst nach Eingabe der der Auftragsummer in Spalte C möglich.
If Cells(Target.Row, 3) = "" Then
Application.EnableEvents = False
Target = ""
Application.EnableEvents = True
End If


'Wenn ein Wert in den besagten Zellen geändert wird soll gefragt werden ob die Änderung richtig ist
'und der alte sowie neue Wert angezeigt werden. Erst nach bestätigung kann der Wert geändert werden.
If Not myOldRange Is Nothing Then
old = myOldValues(Target.Row - myOldRange.Row + 1, Target.Column - myOldRange.Column + 1)
If Not IsEmpty(old) And Target.Value <> old Then
Frage = MsgBox("Wollen Sie den Wert " & old & " durch " & Target.Value & " ersetzen?", vbYesNo + vbQuestion)
If Frage = vbNo Then 'wenn Änderung doch nicht gewollt
Application.EnableEvents = False
Target.Value = old 'setzt den Wert zurück
Application.EnableEvents = True
ElseIf Frage = vbYes And Target.Column = 7 Then 'Wenn Liefertermin (Spalte G) geändert
'Eine Änderung des bereits eingegeben Datums muss begründet werden und de Begründung in einer Textbox
'eingegeben sowie angezeigt werden. Auch das Anfangsdatum sollte dann noch ersichtlich sein.
begr = InputBox("Geben Sie eine kurze Begründung zur Änderung des Liefertermins ein.")
If Target.Comment Is Nothing Then
Target.AddComment "alt: " & old & " neu: " & Target.Value & " " & begr 'Fügt einen Kommentar an
Else 'Fügt dem bestehenden Kommentar weiteren Text hinzu
Target.Comment.Text Target.Comment.Text & Chr(10) & "alt: " & old & " neu: " & Target.Value & " " & begr
End If
End If
End If
End If

Set myOldRange = Me.UsedRange
myOldValues = myOldRange

End Sub

Public Sub Worksheet_Deactivate()
'wechsel des Tabellenblattes ohne vorherige Eingabe nicht möglich.
If CheckChange = False Then Exit Sub

'Beim Verlassen des Sheets wird wieder die Standardrichtung des Users eingestellt.
'MsgBox Test
Application.MoveAfterReturn = myMove
If Application.MoveAfterReturn = True Then
Application.MoveAfterReturnDirection = myReturnDirection
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
CheckChange
Application.EnableEvents = True
End Sub
Friend Function CheckChange() As Boolean
'Prüft ob alle Pflichtfelder ausgefüllt sind
myRange = Me.Range(Cells(2, 3), Cells(Me.UsedRange.Rows.Count + Me.UsedRange.Row - 1, 3)).Value
If IsArray(myRange) Then
z = 1
For Each m In myRange 'Durchläuft die Datensatzzeilen
z = z + 1
If m <> "" Then 'Wenn Auftragsnr vorhanden
'Prüft die Anzahl der Einträge nach Auftragsnr.
If Application.CountA(Me.Range(Cells(z, 4), Cells(z, 23))) < 20 Then
If Me.Name <> ActiveSheet.Name Then
Application.EnableEvents = False
Me.Activate 'Wechselt zum Aktuellen Blatt zurück
Application.EnableEvents = True
End If
For Each leer In Me.Range(Cells(z, 4), Cells(z, 23))
If leer = "" Then 'sucht die Leere Zelle im Datensatz
leer.Select
MsgBox "Bitte geben Sie hier einen Wert ein."
Exit Function
End If
Next leer
End If
End If
Next m
End If
CheckChange = True

End Function

Klicke nun auf "Diese Arbeismappe" und füge noch diesen Code ein:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Tabelle1.CheckChange = False Then
Cancel = True
Else
If ThisWorkbook.Saved = False Then
Frage = MsgBox("Möchten Sie diese Datei vor dem Schließen speichern?", vbYesNoCancel + vbQuestion)
If Frage = vbCancel Then
Cancel = True
Exit Sub
ElseIf Frage = vbNo Then
ThisWorkbook.Saved = True
Else
ThisWorkbook.Save
End If
Tabelle1.Worksheet_Deactivate
End If
End If

End Sub

Private Sub Workbook_Open()
Tabelle1.Worksheet_Activate
End Sub

Ersetze dabei ggf. Tabelle1 durch den VBA Namen deiner Tabelle

Solltest du Probleme haben, meld dich einfach noch mal.

Gruß Mr. K.

Answer 2

Grad noch zwei kleine Bugs entdeckt (Irgendwas ist immer!):
Du solltest im Worksheet Change ereignis die Zeile If Not myOldRange Is Nothing Then durch
If Not myOldRange Is Nothing And Target.colum >= 4 Then ersetzen um Probleme beim Löschen von Zeilen zu vermeiden.
Das Löschen von Zeilen an sich, lässt sich nur unterbinden, wenn du das Tabellenblatt schützt und zuvor die Spalten C bis W zur Bearbeitung freigibst.

Außerdem solltest du noch in der CheckChange Funktion den Block

If leer = "" Then 'sucht die Leere Zelle im Datensatz
leer.Select
MsgBox "Bitte geben Sie hier einen Wert ein."
Exit Function
End If

durch

If leer = "" Then 'sucht die Leere Zelle im Datensatz
If leer.Address <> ActiveCell.Address Then
leer.Select
MsgBox "Bitte geben Sie hier einen Wert ein."
End If
Exit Function
End If

ersetzen. Das verbessert die Benutzerfreundlichkeit.

PS: Den Trick mit der Kopie der Range Werte in das Array "myOldValues" hab' ich von Nighty. Einen netten Gruß an dieser Stelle :-)

Mr. K.

Answer 3

Hallo King,

erstmal vielen herzlichen Dank für die Zeit die du darin investiert hast. Sowas ist nicht selbstverständich und ich hätte mit einer so umfangreichen Lösung meiner Aufgabenstellung nicht gerechnet. Wirklich Top! Hatte schon Angst das diese Aufgabe zu umfangreich für ein Forum ist :-) Nochmals vielen Dank :-)

Ich habe alles wie von dir oben beschrieben umgesetzt. Bei dem löschen einer Zeile tritt jedoch ein Fehler auf. Ich habe

If Not myOldRange Is Nothing Then durch
If Not myOldRange Is Nothing And Target.colum >= 4 Then ersetzt.

Folgender Fehlercode erscheint:
Laufzeitfehler 438
Objekt unterstützt diese Eigenschaft oder Methode nicht.

Es wäre auch gut wenn man vor dem löschen einer Zeile gefragt wird ob diese wirklich gelöscht werden soll.
Kann aber muss nicht. Eigentlich wüsste ich nicht warum der User eine Zeile bzw. den Auftrag löschen sollte.
Somit würde auch die Statistik verfälscht. Also zur Not kann das löschen einer Zeile auch verboten werden mit dem Makro.

Ein paar kleine Bitten habe ich noch :-) :

Wenn der User einen falschen Wert in einer Zelle eingegeben hat, sollte er sich in der Zeile "bewegen" und den Wert ändern können. Nach der Abfrage ob der Wert x durch y ersetzt werden soll, muss die Zeile weiter ausgefüllt werden. Ansonsten muss er ja erst die komplette Zeile ausfüllen bevor er den falschen Wert ändern kann. Ich hoffe das ist möglich :-)

Wir haben mehrere Aufträge mit gleichem und unterschiedlichem Datum in den Zeilen. Da ich auch eine Filterfunktion nutze, wollte ich fragen ob es möglich ist, zwischen den Aufträgen mit unterschiedlichem Datum automatisch eine freie Zeile zu lassen. Das erleichtert die Übersicht. Alle kann nix muss. :-) Für Alternativen bin ich auch offen.

Die erzwungene Eingabe habe ich bis Spalte 22 begrenzt. In der Spalte 23 können zusätzliche Kommentare verfasst werden.
Da diese Kommentare oft relativ lang sind, wollte ich fragen ob man dieses Kommentar nach Eingabe automatisch in ein Textfeld übernehmen kann. Das würde die Sache auch übersichtlicher machen.

Vorab schonmal vielen Dank für deine weitere Hilfe. Ich hoffe das wirkt nicht unverschämt...

Liebe Grüße
Sebastian

Anbei noch dein Makro:
-------------------------------------------------------------------------------------------------------------------------------------------------------
Arbeitsmappe:
--------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Tabelle1.CheckChange = False Then
Cancel = True
Else
If ThisWorkbook.Saved = False Then
Frage = MsgBox("Möchten Sie diese Datei vor dem Schließen speichern?", vbYesNoCancel + vbQuestion)
If Frage = vbCancel Then
Cancel = True
Exit Sub
ElseIf Frage = vbNo Then
ThisWorkbook.Saved = True
Else
ThisWorkbook.Save
End If
Tabelle1.Worksheet_Deactivate
End If
End If

End Sub

Private Sub Workbook_Open()
Tabelle1.Worksheet_Activate
End Sub
-----------------------------------------------------------------------------------------------------------------------------------------------------------
Tabelle1:
-----------------------------------------------------------------------------------------------------------------------------------------------------------
Private myReturnDirection As XlDirection
Private myMove As Boolean
Private myOldRange As Range
Private myOldValues As Variant

Public Sub Worksheet_Activate()

'Nach erfolgter Eingabe in C soll automatisch zur nächsten Zelle
'gesprungen werden um dort eine Eingabe zu machen. - Nur für dieses Sheet gültig
'Speichern der Nutzereinstellungen
myMove = Application.MoveAfterReturn
myReturnDirection = Application.MoveAfterReturnDirection
'Eingabetaste = Sprung nach rechts
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlToRight

Set myOldRange = Me.UsedRange
myOldValues = myOldRange

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)


'Eine Eingabe in den Spalten D bis W ist erst nach Eingabe der der Auftragsummer in Spalte C möglich.
If Cells(Target.Row, 3) = "" Then
Application.EnableEvents = False
Target = ""
Application.EnableEvents = True
End If


'Wenn ein Wert in den besagten Zellen geändert wird soll gefragt werden ob die Änderung richtig ist
'und der alte sowie neue Wert angezeigt werden. Erst nach bestätigung kann der Wert geändert werden.
If Not myOldRange Is Nothing And Target.colum >= 4 Then
old = myOldValues(Target.Row - myOldRange.Row + 1, Target.Column - myOldRange.Column + 1)
If Not IsEmpty(old) And Target.Value <> old Then
Frage = MsgBox("Wollen Sie den Wert " & old & " durch " & Target.Value & " ersetzen?", vbYesNo + vbQuestion)
If Frage = vbNo Then 'wenn Änderung doch nicht gewollt
Application.EnableEvents = False
Target.Value = old 'setzt den Wert zurück
Application.EnableEvents = True
ElseIf Frage = vbYes And Target.Column = 7 Then 'Wenn Liefertermin (Spalte G) geändert
'Eine Änderung des bereits eingegeben Datums muss begründet werden und de Begründung in einer Textbox
'eingegeben sowie angezeigt werden. Auch das Anfangsdatum sollte dann noch ersichtlich sein.
begr = InputBox("Geben Sie eine kurze Begründung zur Änderung des Liefertermins ein.")
If Target.Comment Is Nothing Then
Target.AddComment "alt: " & old & " neu: " & Target.Value & " " & begr 'Fügt einen Kommentar an
Else 'Fügt dem bestehenden Kommentar weiteren Text hinzu
Target.Comment.Text Target.Comment.Text & Chr(10) & "alt: " & old & " neu: " & Target.Value & " " & begr
End If
End If
End If
End If

Set myOldRange = Me.UsedRange
myOldValues = myOldRange

End Sub

Public Sub Worksheet_Deactivate()
'wechsel des Tabellenblattes ohne vorherige Eingabe nicht möglich.
If CheckChange = False Then Exit Sub

'Beim Verlassen des Sheets wird wieder die Standardrichtung des Users eingestellt.
'MsgBox Test
Application.MoveAfterReturn = myMove
If Application.MoveAfterReturn = True Then
Application.MoveAfterReturnDirection = myReturnDirection
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
CheckChange
Application.EnableEvents = True
End Sub
Friend Function CheckChange() As Boolean
'Prüft ob alle Pflichtfelder ausgefüllt sind
myRange = Me.Range(Cells(2, 3), Cells(Me.UsedRange.Rows.Count + Me.UsedRange.Row - 1, 3)).Value
If IsArray(myRange) Then
Z = 1
For Each m In myRange 'Durchläuft die Datensatzzeilen
Z = Z + 1
If m <> "" Then 'Wenn Auftragsnr vorhanden
'Prüft die Anzahl der Einträge nach Au

Answer 4

Hallo Sebastian:

Folgender Fehlercode erscheint:
Laufzeitfehler 438

Uups, da hab ich mich am späten Abend noch vertippt. Es muss natürlich And Target.column >= 4 heißen.

Die Lösung ist leider deshalb so umfangreich geraten, da Excel die Ereignisse Change, Selection.Change und SheetChange erst nach der Änderung auslöst und keinen Bezug auf die vorherigen Werte liefert. Diese müssen leider umständlich per Code wieder gesucht werden um die Änderung rückgängig machen zu können.

Eine Abfrage vor dem Löschen von Zeilen ist daher leider nicht möglich, da auch hier das ChangeEvent erst nach dem Löschen ausgelöst wird. Wie ich bereits schrieb, kannst du das Zeilenlöschen nur über den Blattschutz verbieten. Solltest du dabei ein Passwort verwenden musst du das noch im Code im Block "Zeile einfügen bei unterschiedlichem Datum" hinterlegen.

Ansonsten hier nochmal der gesamte Code inklusive deiner Anpassungswünsche. Das ist leichter als die Anpassungen im Detail zu besprechen.

Private myReturnDirection As XlDirection
Private myMove As Boolean
Private myOldRange As Range
Private myOldValues As Variant
Private myOldCell As Range

Public Sub Worksheet_Activate()

'Nach erfolgter Eingabe in C soll automatisch zur nächsten Zelle
'gesprungen werden um dort eine Eingabe zu machen. - Nur für dieses Sheet gültig
'Speichern der Nutzereinstellungen
myMove = Application.MoveAfterReturn
myReturnDirection = Application.MoveAfterReturnDirection
'Eingabetaste = Sprung nach rechts
If Not myMove Then Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlToRight

Set myOldRange = Me.UsedRange
Set myOldCell = ActiveCell
myOldValues = myOldRange


End Sub

Private Sub Worksheet_Change(ByVal Target As Range)


'Eine Eingabe in den Spalten D bis W ist erst nach Eingabe der der Auftragsummer in Spalte C möglich.
If Cells(Target.Row, 3) = "" Then
Application.EnableEvents = False
Target = ""
Application.EnableEvents = True
End If


'Wenn ein Wert in den besagten Zellen geändert wird soll gefragt werden ob die Änderung richtig ist
'und der alte sowie neue Wert angezeigt werden. Erst nach bestätigung kann der Wert geändert werden.
If Not myOldRange Is Nothing And Target.Column >= 4 Then
old = myOldValues(Target.Row - myOldRange.Row + 1, Target.Column - myOldRange.Column + 1)
If Not IsEmpty(old) And Not IsArray(old) Then
If Target.Value <> old Then
Frage = MsgBox("Wollen Sie den Wert " & old & " durch " & Target.Value & " ersetzen?", vbYesNo + vbQuestion)
If Frage = vbNo Then 'wenn Änderung doch nicht gewollt
Application.EnableEvents = False
Target.Value = old 'setzt den Wert zurück
Application.EnableEvents = True
ElseIf Frage = vbYes And Target.Column = 7 Then 'Wenn Liefertermin (Spalte G) geändert
'Eine Änderung des bereits eingegeben Datums muss begründet werden und de Begründung in einer Textbox
'eingegeben sowie angezeigt werden. Auch das Anfangsdatum sollte dann noch ersichtlich sein.
Do
begr = InputBox("Geben Sie eine kurze Begründung zur Änderung des Liefertermins ein.")
Loop Until begr <> ""
If Target.Comment Is Nothing Then
Target.AddComment "alt: " & old & " neu: " & Target.Value & " " & begr 'Fügt einen Kommentar an
Else 'Fügt dem bestehenden Kommentar weiteren Text hinzu
Target.Comment.Text Target.Comment.Text & Chr(10) & "alt: " & old & " neu: " & Target.Value & " " & begr
End If
End If
End If
End If

'Fügt bei einem neuen Lieferdatum (Spalte G) eine Leerzeile ein
If Target.Row > 1 Then
If Target.Column = 7 And Target.Value <> Target.Offset(-1, 0).Value And IsDate(Target.Offset(-1, 0)) Then
If Me.ProtectContents Then
Me.Unprotect "Passwort"
Target.EntireRow.Insert
Me.Protect "Passwort"
Else
Target.EntireRow.Insert
End If
End If
End If
End If


'Kommentar aus Zellinhalt übernehmen (Spalte W)
If Target.Column = 23 Then
If Target.Comment Is Nothing Then
Target.AddComment Application.UserName & ":" & Chr(10) & Target.Value
Else
Target.Comment.Text Application.UserName & ":" & Chr(10) & Target.Value
End If
End If

Set myOldRange = Me.UsedRange
Set myOldCell = ActiveCell
myOldValues = myOldRange

End Sub

Public Sub Worksheet_Deactivate()
'wechsel des Tabellenblattes ohne vorherige Eingabe nicht möglich.
If CheckChange = False Then Exit Sub

'Beim Verlassen des Sheets wird wieder die Standardrichtung des Users eingestellt.
'MsgBox Test
Application.MoveAfterReturn = myMove
If Application.MoveAfterReturn = True Then
Application.MoveAfterReturnDirection = myReturnDirection
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not myOldCell Is Nothing Then
If myOldCell.Row <> Target.Row Then
Application.EnableEvents = False
CheckChange
Application.EnableEvents = True
End If
End If
Set myOldCell = ActiveCell
End Sub
Friend Function CheckChange() As Boolean
'Prüft ob alle Pflichtfelder ausgefüllt sind
myRange = Me.Range(Cells(2, 3), Cells(Me.UsedRange.Rows.Count + Me.UsedRange.Row - 1, 3)).Value
If IsArray(myRange) Then
z = 1
For Each m In myRange 'Durchläuft die Datensatzzeilen
z = z + 1
If m <> "" Then 'Wenn Auftragsnr vorhanden
'Prüft die Anzahl der Einträge nach Auftragsnr.
If Application.CountA(Me.Range(Cells(z, 4), Cells(z, 22))) < 19 Then
If Me.Name <> ActiveSheet.Name Then
Application.EnableEvents = False
Me.Activate 'Wechselt zum Aktuellen Blatt zurück
Application.EnableEvents = True
End If
For Each leer In Me.Range(Cells(z, 4), Cells(z, 22))
If leer = "" Then 'sucht die Leere Zelle im Datensatz
If leer.Address <> ActiveCell.Address Then
leer.Select
MsgBox "Bitte geben Sie hier einen Wert ein."
End If
Exit Function
End If
Next leer
End If
End If
Next m
End If
CheckChange = True

End Function

Der code im Modul "Diese Arbeitsmappe" hat sich dabei nicht geändert.

Vorab schonmal vielen Dank für deine weitere Hilfe. Ich hoffe das wirkt nicht unverschämt...

Überhaupt nicht. Du schreibst ja, dass du noch nicht so viel Erfahrung hast und ich muss zugeben, dass die Aufgabe etwas umständlich zu lösen war. Wenn du mal Zeit hast, schau dir doch den code dann Zeile

Answer 5

Hallo King,

Nochmals vielen Dank. Super Arbeit! Mein Interesse an VBA ist bereits vor ein paar Wochen/Monaten geweckt worden. Ich habe schon einige Probleme durch ausprobieren selbst lösen können wenn Fehler aufgetreten sind. Bisher war es immer so das ich nach fertigen Makros im Netz gesucht habe und mir diese nach meinen Bedürfnissen (soweit machbar) abgeändert habe. Dieses mal ist es aber ganz anders und nicht vergleichbar mit den bisherigen Makros die ich hatte. :-)

Ansonsten funktioniert dein Makro wirklich super. Anfangs hatte ich Probleme die anderen Makros noch zum laufen zu bekommen. Aber nun habe ich wieder einiges dazu gelernt und es doch noch geschafft.

An ein paar Stellen komme ich jedoch nicht weiter. Sind eigentlich nur Kleinigkeiten die aber wichtig sind und das Makro bzw. die Tabelle perfekt machen würden.

Wenn der Endtermin überschritten und bergündet wurde, soll die Zelle rot markiert werden. Auch hier sollte angezeigt werden, wer den Termin geändert hat. (Wie im Kommentarfeld)

Die Größe des Kommtarfensters reicht für die Einträge nicht aus. Das Fenster sollte sich automatisch dem Inhalt anpassen. (Da habe ich schon ein paar Makros gefunden und ausprobiert das anzupassen... Leider ohne Erfolg).

Der Kommentartext sollte nach Eingabe in der Zelle ausgeblendet werden und nur im Kommentarfeld ersichtlich sein.

Kannst du bitte auch nochmal drüberschauen ob ich dein Makro richtig geändert und die anderen richtig eingefügt habe. Laufen tut es jedenfalls ohne Fehler bis jetzt. Ich habe die erzwungene Eingabe ab Spalte B (2) bis V (22) geändert. Sind die Änderungen richtig? Falls nicht wäre es nett wenn du mir nochmal aufzeigen kannst welche Werte ich in solchen Fällen zu ändern habe.

Vorab wieder vielen Dank für deine Mithilfe.

Answer 6

Achso hier noch das Makro:

Diese Arbeitsmappe:
-----------------------------------------------------------------------------------------------------------------------------------------------------------------

'*****************************************************
'* EINGABEN ERZWINGEN *
'* Danke an King *
'* 06.07.2015 *
'*****************************************************

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Tabelle1.CheckChange = False Then
Cancel = True
Else
If ThisWorkbook.Saved = False Then
Frage = MsgBox("Möchten Sie diese Datei vor dem Schließen speichern?", vbYesNoCancel + vbQuestion)
If Frage = vbCancel Then
Cancel = True
Exit Sub
ElseIf Frage = vbNo Then
ThisWorkbook.Saved = True
Else
ThisWorkbook.Save
End If
Tabelle1.Worksheet_Deactivate
End If
End If

End Sub

Private Sub Workbook_Open()
Tabelle1.Worksheet_Activate
End Sub

'*****************************************************
'* AUTOMATISCHES BACKUP ERSTELLEN, BENUTZER ANZEIGEN *
'* 06.07.2015 *
'*****************************************************

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim SavePath As String
Dim FileName As String
Dim FileExtension As String
Dim FileDate As String
Dim FileBackupName As String
Dim FileUsername As String

SavePath = "T:\Fertigung\Fertigungssteuerung\GATES\Auftragsübersicht\Backup\"
FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
FileExtension = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") + 1)
FileUsername = Environ("UserName")

FileDate = Format(Now, "dd-mm-YYYY_hh-mm")
FileBackupName = SavePath & FileName & "_" & FileUsername & "_" & FileDate & "." & FileExtension
ActiveWorkbook.SaveCopyAs FileBackupName

End Sub
--------------------------------------------------------------------------------------------------------------------------------------------------------

Answer 7

Tabelle1 (Teil1):

'**************************************************
'* EINGABE ERZWINGEN *
'* Danke an King *
'* 06.07.2015 *
'**************************************************

Private myReturnDirection As XlDirection
Private myMove As Boolean
Private myOldRange As Range
Private myOldValues As Variant
Private myOldCell As Range

Public Sub Worksheet_Activate()

'Nach erfolgter Eingabe in C soll automatisch zur nächsten Zelle
'gesprungen werden um dort eine Eingabe zu machen. - Nur für dieses Sheet gültig
'Speichern der Nutzereinstellungen
myMove = Application.MoveAfterReturn
myReturnDirection = Application.MoveAfterReturnDirection
'Eingabetaste = Sprung nach rechts
If Not myMove Then Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlToRight

Set myOldRange = Me.UsedRange
Set myOldCell = ActiveCell
myOldValues = myOldRange

End Sub

'**************************************************
'* BEARBEITER UND DATUM ANZEIGEN *
'* 06.07.2015 *
'**************************************************

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objRange As Range, objCell As Range
Set objRange = Intersect(Target, Columns(3))
If Not objRange Is Nothing Then
Application.EnableEvents = False
For Each objCell In objRange
objCell.Offset(, 24).Value = Application.UserName 'Environ$("USERNAME")
objCell.Offset(, 25).Value = Date
Next
Application.EnableEvents = True
End If

'**************************************************
'* EINGABE ERZWINGEN *
'* Danke an King *
'* 06.07.2015 *
'**************************************************

'Eine Eingabe in den Spalten D bis W ist erst nach Eingabe der der Auftragsummer in Spalte C möglich.
If Cells(Target.Row, 2) = "" Then
Application.EnableEvents = False
Target = ""
Application.EnableEvents = True
End If

'Wenn ein Wert in den besagten Zellen geändert wird soll gefragt werden ob die Änderung richtig ist
'und der alte sowie neue Wert angezeigt werden. Erst nach bestätigung kann der Wert geändert werden.

If Not myOldRange Is Nothing And Target.Column >= 4 Then
old = myOldValues(Target.Row - myOldRange.Row + 1, Target.Column - myOldRange.Column + 1)
If Not IsEmpty(old) And Not IsArray(old) Then
If Target.Value <> old Then
Frage = MsgBox("Wollen Sie den Wert " & old & " durch " & Target.Value & " ersetzen?", vbYesNo + vbQuestion)
If Frage = vbNo Then 'wenn Änderung doch nicht gewollt
Application.EnableEvents = False
Target.Value = old 'setzt den Wert zurück
Application.EnableEvents = True
ElseIf Frage = vbYes And Target.Column = 7 Then 'Wenn Liefertermin (Spalte G) geändert
'Eine Änderung des bereits eingegeben Datums muss begründet werden und de Begründung in einer Textbox
'eingegeben sowie angezeigt werden. Auch das Anfangsdatum sollte dann noch ersichtlich sein.
Do
begr = InputBox("Geben Sie eine kurze Begründung zur Änderung des Liefertermins ein.")
Loop Until begr <> ""
If Target.Comment Is Nothing Then
Target.AddComment "alt: " & old & " neu: " & Target.Value & " " & begr 'Fügt einen Kommentar an
Else 'Fügt dem bestehenden Kommentar weiteren Text hinzu
Target.Comment.Text Target.Comment.Text & Chr(10) & "alt: " & old & " neu: " & Target.Value & " " & begr
End If
End If
End If
End If

'Fügt bei einem neuen Lieferdatum (Spalte G) eine Leerzeile ein
If Target.Row > 1 Then
If Target.Column = 7 And Target.Value <> Target.Offset(-1, 0).Value And IsDate(Target.Offset(-1, 0)) Then
If Me.ProtectContents Then
Me.Unprotect "Passwort"
Target.EntireRow.Insert
Me.Protect "Passwort"
Else
Target.EntireRow.Insert
End If
End If
End If
End If

'Kommentar aus Zellinhalt übernehmen (Spalte W)
If Target.Column = 23 Then
If Target.Comment Is Nothing Then
Target.AddComment Application.UserName & ":" & Chr(10) & Target.Value
Else
Target.Comment.Text Application.UserName & ":" & Chr(10) & Target.Value
End If
End If

Set myOldRange = Me.UsedRange
Set myOldCell = ActiveCell
myOldValues = myOldRange

End Sub

Public Sub Worksheet_Deactivate()
'wechsel des Tabellenblattes ohne vorherige Eingabe nicht möglich.
If CheckChange = False Then Exit Sub

'Beim Verlassen des Sheets wird wieder die Standardrichtung des Users eingestellt.
'MsgBox Test
Application.MoveAfterReturn = myMove
If Application.MoveAfterReturn = True Then
Application.MoveAfterReturnDirection = myReturnDirection
End If
End Sub

Answer 8

Tabelle 1 (Teil2)

'**************************************************
'* KALENDER *
'* 06.07.2015 *
'**************************************************

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim RaBereich As Range ' Varable Bereich Wirksamkeit
' von Nepumuk Anzahl der ausgewählten Zellen
If CallByName(Selection, IIf(Val( _
Application.Version) > 11, "CountLarge", "Count"), VbGet) = 1 Then
' Bereich der Wirksamkeit
Set RaBereich = Range("G6:H5000")
' noch mehr Bereiche
'Set RaBereich = Union(Range("C11:AG11 , C13:AG13, C15:AG15 , C17:AG17"), _
Range("C35:AE35, C37:AE37, C43:AG43, C45:AG45 , C47:AG47 , C49:AG49"), _
Range("C67:AF67 , C69:AF69 , C75:AG75 , C77:AG77 , C79:AG79 , C81:AG81"), _
Range("C99:AF99 , C101:AF101, C107:AG107 , C109:AG109 , C111:AG111"), _
Range("C127:AG127 , C129:AG129 , C131:AG131 , C133:AG133 , C139:AF139"), _
Range("C155:AG155, C157:AG157 , C159:AG159 , C161:AG161 , C163:AG163"), _
Range("C179:AF179 , C181:AF181, C187:AG187 , C189:AG189 , C191:AG191"))
'ActiveSheet.Unprotect ("Passwort") ' Schutz der Tabelle aufheben
' prüfen ob Zelle im Bereich, dann Userform starten
If Not Intersect(Target, RaBereich) Is Nothing Then
'ActiveSheet.unprotect ("Passwort") ' Schutz auf Tabelle setzen
If IsDate(ActiveCell) Then
frm_Kalender.Tag = ActiveCell
ElseIf InStr(ActiveCell, "/") > 0 Then
DaDatumUe = DateSerial(Mid(ActiveCell, InStr(ActiveCell, "/") + 1), 1, 1) _
+ Left(ActiveCell, InStr(ActiveCell, "/") - 1) * 7 _
- Weekday(DateSerial(Mid(ActiveCell, InStr(ActiveCell, "/") + 1), 1, 1), 2)
If Weekday(DateSerial(Mid(ActiveCell, InStr(ActiveCell, "/") + 1), 1, 1), 2) > 4 Then
DaDatumUe = DaDatumUe + 1
Else
DaDatumUe = DaDatumUe - 6
End If
frm_Kalender.Tag = DaDatumUe
ElseIf ActiveCell = "" Then
If IsDate(Range("D2")) Then
frm_Kalender.Tag = Range("D2")
Else
frm_Kalender.Tag = Date
End If
End If
frm_Kalender.Show
'ActiveSheet.protect ("Passwort") ' Schutz auf Tabelle setzen
End If
Set RaBereich = Nothing ' Variable löschen
End If

'**************************************************
'* EINGABE ERZWINGEN *
'* Danke an King *
'* 06.07.2015 *
'**************************************************

If Not myOldCell Is Nothing Then
If myOldCell.Row <> Target.Row Then
Application.EnableEvents = False
CheckChange
Application.EnableEvents = True
End If
End If
Set myOldCell = ActiveCell
End Sub
Friend Function CheckChange() As Boolean
'Prüft ob alle Pflichtfelder ausgefüllt sind
myRange = Me.Range(Cells(2, 3), Cells(Me.UsedRange.Rows.Count + Me.UsedRange.Row - 1, 3)).Value
If IsArray(myRange) Then
Z = 1
For Each M In myRange 'Durchläuft die Datensatzzeilen
Z = Z + 1
If M <> "" Then 'Wenn Auftragsnr vorhanden
'Prüft die Anzahl der Einträge nach Auftragsnr.
If Application.CountA(Me.Range(Cells(Z, 3), Cells(Z, 22))) < 19 Then
If Me.Name <> ActiveSheet.Name Then
Application.EnableEvents = False
Me.Activate 'Wechselt zum Aktuellen Blatt zurück
Application.EnableEvents = True
End If
For Each leer In Me.Range(Cells(Z, 3), Cells(Z, 22))
If leer = "" Then 'sucht die Leere Zelle im Datensatz
If leer.Address <> ActiveCell.Address Then
leer.Select
MsgBox "Bitte geben Sie hier einen Wert ein."
End If
Exit Function
End If
Next leer
End If
End If
Next M
End If
CheckChange = True

End Function

------------------------------------------------------------------------------------------------------------------------------

Die Formulare, Module und Klassenmodule habe ich erstmal weggelassen. Falls du die auch brauchst kannst du gerne
bescheid sagen. Ich kann dir auch die ganze Datei schicken... Ist vllt. einfacher?

Gruss
Sebastian

Answer 9

Hallo Sebastian,

ein paar Sachen habe ich noch nicht so ganz verstanden:

"Wenn der Endtermin überschritten und begründet wurde, soll die Zelle rot markiert werden. Auch hier sollte angezeigt werden, wer den Termin geändert hat. (Wie im Kommentarfeld)."

Wie willst du das prüfen? Legst du einige Aufträge erst nach Lieferdatum an? Das kann ich mir nicht vorstellen. Was passiert denn genau, wenn ein Auftrag erledigt ist. Wird er dann gelöscht oder in einer Spalte als erledigt markiert? Denn nur dann macht das Einfärben des überfälligen Datums Sinn. Das musst du auch nicht unbedingt über Makro machen. Einfach eine Bedingte Formatierung mit der Formel =G2<Heute() oder =UND(G2<Heute();X2="") hinterlegen wobei in Spalte X die ErledigtMarkierung steht, und mit Format-Übertragen (das Pinsel-Symbol) nach unten kopieren.

Die Größe des Kommtarfensters reicht für die Einträge nicht aus. Das Fenster sollte sich automatisch dem Inhalt anpassen. (Da habe ich schon ein paar Makros gefunden und ausprobiert das anzupassen... Leider ohne Erfolg).

Vielleicht bin ich ja blind, aber diesen Teil habe ich in deinem angepassten code noch nicht entdeckt. So richtig kann ich mir das auch nicht vorstellen, wie das gehen soll. Du kannst, wie bei allen Objekten mit der With bzw. Height Eigenschaft die Größe festlegen. Es gibt jedoch keine festgelegte Größe die automatisch an den Inhalt angepasst werden könnte. Der Kommentar kann entweder sehr breit aber nur 2 zeilig werden oder sehr hoch aber dafür schmal. In beiden Fällen würde der gesamte Inhalt dargestellt.
Um den User hier noch hinzuzufügen, ersetze "alt: " durch Application.Username & "alt: "

Der Kommentartext sollte nach Eingabe in der Zelle ausgeblendet werden und nur im Kommentarfeld ersichtlich sein.

Warum bittest du deine Nutzer eigentlich nicht, auf den Eintrag in eine Zelle zu verzichten und gleich einen Kommentar anzulegen.
Wenn du das unbedingt mit Code machen willst. Füge dem Block Kommentar aus Zelle übernehmen die Zeile Target.ClearContents hinzu.

Kannst du bitte auch nochmal drüberschauen ob ich dein Makro richtig geändert und die anderen richtig eingefügt habe. Laufen tut es jedenfalls ohne Fehler bis jetzt

Es gibt keine "richtige" Änderung. Alle Änderungen sind immer richtig, wenn alles wie gewünscht läuft. Auf welchem Weg man diese Anpassung gemacht hat ist nebensächlich. Alles andere ist nur Schönheit des Codes, der höchstens bei langer Durchlaufzeit auf Verbesserungsmöglichkeiten überprüft werden muss.

Vielleicht kannst du ja doch mal eine Datei mit ein paar Beispieldaten (bitte keine echten Kunden) über Dropbox hochladen. Dann kann ich mir vielleicht ein besseres Bild davon machen, wo genau es noch hakt. Das wird dann aber erst morgen Abend werden.

Gruß Mr. K.