MsgBox Looped obwohl Exit Sub
08.12.2020 15:31:50
Hillebrandt
Sie sucht in einer Datenbank bei Eintragung eines neuen Datensatzes ob der Datensatz bereits vorhanden ist.
Das Suchen und Finden funktioniert nach meinem Kenntnisstand tadellos. Jedoch habe ich ein Problem mit meiner Löschfunktion die den doppelten Datensatz löschen soll wenn es von Nutzer gewünscht ist.
Die dem Vorgeschaltete MsgBox öffnet sich immer wieder. Mal öffnete sie sich bei vbYes 2 mal, Mal 5 mal. Das Löschen an sich wird auch ausgeführt jedoch wie gewünscht schon beim ersten vbYes druck ausgeführt. Ein auslösen von vbNo hingegen beendet, wie gewünscht, in 100% der Fälle sofort das Sub.
Anbei der entsprechende Code.
Vielen Dank schon einmal im Voraus.
Private Sub Worksheet_Change(ByVal Target As Range)
Zeile = Target.Row
Spalte = Target.Column
Dim Result As VbMsgBoxResult
Dim Ro, co, Erg As Integer
Dim c As Range
Ro = Sheets("Positive Fälle").Columns(Spalte).Find(Target.Value, LookAt:=xlPart).Row 'Wird _
_
_
_
Row Wert des ersten Identischen Geburtsdatum
co = Sheets("Positive Fälle").Columns(Spalte).Find(Target.Value, LookAt:=xlPart).Column ' _
Wird Column Wert des ersten Identischen Geburtsdatum
If Target.Column = 6 Then ' _
Trigger für Code ist Änderung der Geburtsdatumsspalte
If Cells(Ro, co).Value = Target.Value Then ' _
Erste Prüfung ob Person Bereits Vorhanden ist: Hier Geburtsdatum WICHTIG nur das erste _
Identische Geburtsdatum wird geprüft
If Cells(Ro, co).Offset(0, -2).Value = Target.Offset(0, -2).Value Then ' _
Erste Prüfung ob Person Bereits Vorhanden ist: Hier Nachname
If Cells(Ro, co).Offset(0, -3).Value = Target.Offset(0, -3).Value Then ' _
Erste Prüfung ob Person Bereits Vorhanden ist: Hier Vorname
GoTo DoppelterEintrag ' _
Wenn erstes Gefundenes Geburtsdatum auch in allen anderen Kriterien richtig dann Meldung Sonst _
_
_
Schleife
Else: GoTo Schleife
End If
Else: GoTo Schleife
Schleife:
Do While Sheets("Positive Fälle").Cells(Ro, 2).Value ""
Set c = Sheets("Positive Fälle").Range(Cells(Ro, 3), Cells(Ro, 6))
Ro = Ro + 1
If Application.WorksheetFunction.CountBlank(c) Target.Offset(0, -2) _
_
_
_
.Address Then
GoTo DoppelterEintrag 'Schleife prüft ab dem ersten identischen _
_
_
_
Geburtsdatum alle Zellen Die Eine IndexNr haben auf Identische Vor- und Nachnamen
End If
End If
End If
Loop
GoTo Fehler
DoppelterEintrag:
Target.Activate
Result = MsgBox("Die Person ist bereits in der Positiven Fälle Liste vorhanden " _
_
_
_
& vbNewLine & vbNewLine _
& "IndexNr: " & Cells(Ro, co).Offset(0, -4).Value & vbNewLine & "Name: " & _
Cells(Ro, co).Offset(0, -3).Value & vbNewLine _
& "Vorname: " & Cells(Ro, co).Offset(0, -2).Value & vbNewLine & "Geschlecht: " & _
_
_
_
Cells(Ro, co).Offset(0, -1).Value & vbNewLine _
& "Geburtdatum: " & Cells(Ro, co).Value & vbNewLine & vbNewLine & "Wollen sie _
_
_
_
diese Person nochmals neu anlegen?", vbCritical + vbYesNo, "Index bereits vorhanden!")
If Result = vbYes Then 'Wenn Eintragung gelöscht werden soll dann Nein _
sonst Ja
Exit Sub
ElseIf Result = vbNo Then
Result = MsgBox("Wollen sie ihre bisherige Eingabe wirklich Löschen?", _
_
_
_
vbCritical + vbYesNo, "Index bereits vorhanden") 'Weiter Prüfung ob Gelöscht werden soll
If Result = vbYes Then
With Target
.ClearContents
.Offset(0, -1).ClearContents
.Offset(0, -2).ClearContents
.Offset(0, -3).ClearContents
.Offset(0, -3).Activate
End With
Exit Sub 'hier Looped sich die MsgBox löscht _
zwar den Inhalt der Zellen öfnet aber bis man auf vbNo klickt sich einige male
ElseIf Result = vbNo Then
Exit Sub
ElseIf Result = vbAbort Then
Exit Sub
ElseIf Result = vbAbort Then
Exit Sub
End If
End If
End If
End If
End If