Excel VBA Datenüberprüfung beim Einfügen (Strg+V) von Text in Zelle aufrecht erhalten?
Hallo zusammen,
ich greife gerade im Rahmen eines Projekts per Datenüberprüfung auf eine Auswahl von 6000+ Zellen zu und möchte falls ein Teil, das nicht zu den 6000 gehört eine Fehlermeldung ausgeben. Nun habe ich die Problematik, dass die Zelle mit der Datenüberprüfung eine Eingabezelle sein wird, d. h. der Benutzer wird Werte aus anderen XML Dokumenten hereinkopieren. Dies Formatiert die Zelle aber Standardmäßig um und entfernt die eingerichtete Datenüberprüfung.
Gibt es hier eine einfache Lösung dies zu verhindern? Ich habe es auch schon mit Excel VBA versucht (s. Quelltext) aber hier konnte ich nur die Datenüberprüfung nachdem sie entfernt wurde wieder hinzufügen. Das Problem hierbei ist, dass dem User keine Fehlermeldung angezeigt wird nachdem er den Text in die Zelle kopiert hat.
Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$A$2" Then
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator _
:=xlBetween, Formula1:="='Zuord. Teil-Kart. Datenquelle '!$A$1:$A$6168"
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = "Teil nicht verfügbar"
.InputMessage = ""
.ErrorMessage = _
"Teil nicht verfügbar, da:" & Chr(10) & "a) Teil existiert nicht" & Chr(10) & "b) Teil existiert, wird aber nicht in Kartonage verpackt --> Manuelle Frachtberechnung nötig" & Chr(10) & "c) Teil ist neu --> Rückmeldung an *** / ***"
.ShowInput = True
.ShowError = True
End With
End If
1 Antwort
Hallo,
das Überschreiben durch Einfügen zu verhindern ist meines Wissens nach nicht möglich ohne generell alle Möglichkeiten Dinge einzufügen zu blockieren. Das scheint bei dir aber ja nicht zielführend zu sein, daher wäre es eventuell eine Möglichkeit die Datenprüfung im Fall, das etwas eingefügt wurde in VBA zu simulieren und die Eingabe ggfls zu löschen. (den Code müsstest du noch an deine Arbeitsmappe anpassen):
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then
'hier Datenprüfung wiederherstellen
With ActiveSheet
If Application.WorksheetFunction.CountIf(.Range("B:B"), .Range("A2").Value) = 0 Then 'hier .Range("B:B") mit deiner Liste ersetzen ActiveWorkbook.Sheets("Zuord. Teil-Kart. Datenquelle ").Range ("A1:A6168") (?)
MsgBox "Der eingefügte Wert ist ungültig"
Application.EnableEvents = False 'Selbstauslöser verhindern
.Range("A2").ClearContents
Application.EnableEvents = True
End If
End With
End If
End Sub
geht leider immernoch nicht, mein kompletter Code in dem Modul ist nun wie folgt:
Sub asd(ByVal Target As Excel.Range)
If Target.Address = "$A$2" Then
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator _
:=xlBetween, Formula1:="='Zuord. Teil-Kart. Datenquelle '!$A$1:$A$6168"
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = "Teil nicht verfügbar"
.InputMessage = ""
.ErrorMessage = _
"Teil nicht verfügbar, da:" & Chr(10) & "a) Teil existiert nicht" & Chr(10) & "b) Teil existiert, wird aber nicht in Kartonage verpackt --> Manuelle Frachtberechtnung nötig" & Chr(10) & "c) Teil ist neu --> Rückmeldung an U.***/ J.***"
.ShowInput = True
.ShowError = True
End With
Range("A2").Interior.ColorIndex = 35
End If
End Sub
Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then
'hier Datenprüfung wiederherstellen
With ActiveSheet
If Application.WorksheetFunction.CountIf(.Range("V:V"), .Range("$A$2").Value) = 0 Then 'hier .Range("B:B") mit deiner Liste ersetzen ActiveWorkbook.Sheets("Zuord. Teil-Kart. Datenquelle ").Range ("A1:A6168") (?)
MsgBox "Der eingefügte Wert ist ungültig"
Application.EnableEvents = False 'Selbstauslöser verhindern
.Range("A2").ClearContents
Application.EnableEvents = True
End If
End With
End If
End Sub
Eventuell stimmt etwas an der ersten If Bedingung nicht, wenn ich hier mein
________________________
Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then
Range("A2").Interior.ColorIndex = 35
'hier Datenprüfung wiederherstellen
End If
End Sub
___________________________
einsetze, dann färbt sich die Zelle A2 nicht in Color 35
Sorry für den Spam aber es wird immer Verrückter :'-)
jetzt wirft es mir den Error den ich für Zeile A2 programmiert hab in Spalte H:
Sub asd(ByVal Target As Excel.Range)
If Target.Address = "A2" Then
Range("A2").Interior.ColorIndex = 35
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator _
:=xlBetween, Formula1:="='Zuord. Teil-Kart. Datenquelle '!$A$1:$A$6168"
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = "Teil nicht verfügbar"
.InputMessage = ""
.ErrorMessage = _
"Teil nicht verfügbar, da:" & Chr(10) & "a) Teil existiert nicht" & Chr(10) & "b) Teil existiert, wird aber nicht in Kartonage verpackt --> Manuelle Frachtberechtnung nötig" & Chr(10) & "c) Teil ist neu --> Rückmeldung an U.***/ J.***"
.ShowInput = True
.ShowError = True
End With
If Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then
'hier Datenprüfung wiederherstellen
With ActiveSheet
If Application.WorksheetFunction.CountIf(.Range("B:B"), .Range("A2").Value) = 0 Then 'hier .Range("B:B") mit deiner Liste ersetzen ActiveWorkbook.Sheets("Zuord. Teil-Kart. Datenquelle ").Range ("A1:A6168") (?)
MsgBox "Der eingefügte Wert ist ungültig"
Application.EnableEvents = False 'Selbstauslöser verhindern
.Range("A2").ClearContents
Application.EnableEvents = True
End If
End With
End If
End If
End Sub
Hallo nochmal, gestern ist mir leider noch etwas dazwischengekommen und ich konnte es mir erst jetzt genauer ansehen.
Du hast ja geschrieben das du die Datenquelle in V:V verschoben, hast dein Code versucht aber noch 'Zuord. Teil-Kart. Datenquelle '!$A$1:$A$6168" zu hinterlegen. Bei mir funktioniert es wenn ich das behebe:
Sub asd(ByVal Target As Excel.Range)
If Target.Address = "$A$2" Then
With Selection.Validation
.Delete
'.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:="='Zuord. Teil-Kart. Datenquelle '!$A$1:$A$6168"
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:="=$V:$V"
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = "Teil nicht verfügbar"
.InputMessage = ""
.ErrorMessage = "Teil nicht verfügbar, da:" & Chr(10) & "a) Teil existiert nicht" & Chr(10) & "b) Teil existiert, wird aber nicht in Kartonage verpackt --> Manuelle Frachtberechtnung nötig" & Chr(10) & "c) Teil ist neu --> Rückmeldung an U.***/ J.***"
.ShowInput = True
.ShowError = True
End With
Range("A2").Interior.ColorIndex = 35
End If
End Sub
Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then
'hier Datenprüfung wiederherstellen
Call asd(Target)
With ActiveSheet
If Application.WorksheetFunction.CountIf(.Range("V:V"), .Range("$A$2").Value) = 0 Then 'hier .Range("B:B") mit deiner Liste ersetzen ActiveWorkbook.Sheets("Zuord. Teil-Kart. Datenquelle ").Range ("A1:A6168") (?)
MsgBox "Der eingefügte Wert ist ungültig"
Application.EnableEvents = False 'Selbstauslöser verhindern
.Range("A2").ClearContents
Application.EnableEvents = True
End If
End With
End If
End Sub
Eventuell stimmt etwas an der ersten If Bedingung nicht Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut)
:? das Application.Cutcopymode sollte überprüfen ob der Kopiermodus aktiv ist, damit er nicht bei jeder manuellen Änderung ausgelöst wird. Hab jetzt aber festgestellt das er es nicht ist wenn man Daten von außerhalb einer Exceldatei einfügt. Könnte es daran liegen das er nicht ausgelöst hat?
funktioniert danach auch mein erster Sub nicht mehr / jetzt wirft es mir den Error den ich für Zeile A2 programmiert hab in Spalte H
Ok ich hab keine Ahnung warum es das bei dir tut und schaffe es auch nicht zu reproduzieren.
Danke dir nochmal!
Ich habe jetzt deinen Code 1:1 bei mir eingefügt und es geht immer noch nichts :(.
:? das Application.Cutcopymode sollte überprüfen ob der Kopiermodus aktiv ist, damit er nicht bei jeder manuellen Änderung ausgelöst wird. Hab jetzt aber festgestellt das er es nicht ist wenn man Daten von außerhalb einer Exceldatei einfügt. Könnte es daran liegen das er nicht ausgelöst hat?
Geht leider nichts egal ob ich von innerhalb der Exceldatei oder von außerhalb etwas reinkopiere.
Wenn ich deinen Code direkt in Tabelle 2 kopiere, hängt sich mein Excel auf, lädt und stürzt dann ab.
Ich habe es jetzt in einem Modul gespeichert und dann in Tabelle den Code
Sub Datenueberpruefung(ByVal Target As Excel.Range)
Call asd
Call Worksheet_Change
End Sub
Hey, danke schonmal für den Hinweis, dass das was ich mit der Datenüberprüfung machen wollte nicht möglich ist. Und danke auch für den Code.
Irgendwie bringe ich den jetzt aber nicht zum Laufen. Ich habe meine Datenquelle in Spalte V des gleichen Tabellenblatts gesetzt um es etwas einfacher zu halten, funzt aber immernoch nicht :(
Vielleicht kannst du mir weiterhelfen?:
Private Sub CopyDenier(ByVal Target As Range)
If Target.Address(False, False) = "A2" And (Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut) Then
'hier Datenprüfung wiederherstellen
With ActiveSheet
If Application.WorksheetFunction.CountIf(.Range("V:V"), .Range("A2").Value) = 0 Then 'hier .Range("B:B") mit deiner Liste ersetzen ActiveWorkbook.Sheets("Zuord. Teil-Kart. Datenquelle ").Range ("A1:A6168") (?)
MsgBox "Der eingefügte Wert ist ungültig"
Application.EnableEvents = False 'Selbstauslöser verhindern
.Range("A2").ClearContents
Application.EnableEvents = True
End If
End With
End If
End Sub