Gültigkeitsprüfung per VBA
Paulo
Ich benutze folgenden code um in 2 Spalten die Eingabe auf Ihre Gültigkeit zu prüfen. Hatte vorher die Normale Gültigkeitsprüfung war aber mit dem Scrollen nicht so die Sache. Habe es dann in VBA versucht,
Jetzt ist das Scrollen wunderbar nur bei Eingabe dauert es eine Ewigkeit bis er die Prüfung erledigt.
Kann man den Code nicht etwas beschleunigen oder kürzen ?
Im voraus Danke
Paulo
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngC As Range, Meldung As String, rngM As Range
Dim rngD As Range, Meldung1 As String, rngN As Range
If Not Intersect(Target, Columns(5)) Is Nothing And Target.Row >= 30 Then
For Each rngD In Intersect(Target, Columns(5))
Select Case True
Case rngD Like ""
Case rngD Like Range("AI17").Value
Case rngD Like Range("AJ17").Value
Case rngD Like Range("AK17").Value
Case rngD Like Range("AL17").Value
Case rngD Like Range("AM17").Value
Case rngD Like Range("AN17").Value
Case rngD Like Range("AO17").Value
Case rngD Like Range("AP17").Value
Case rngD Like Range("AQ17").Value
Case rngD Like Range("AR17").Value
Case rngD Like Range("AS17").Value
Case rngD Like Range("AT17").Value
Case rngD Like Range("AU17").Value
Case rngD Like Range("AV17").Value
Case rngD Like Range("AW17").Value
Case rngD Like Range("AX17").Value
Case rngD Like Range("AY17").Value
Case rngD Like Range("AZ17").Value
Case rngD Like Range("BA17").Value
Case rngD Like Range("BB17").Value
Case rngD Like Range("BC17").Value
Case rngD Like Range("BD17").Value
Case rngD Like Range("BE17").Value
Case rngD Like Range("BF17").Value
Case rngD Like Range("BG17").Value
Case rngD Like Range("BH17").Value
Case rngD Like Range("BI17").Value
Case rngD Like Range("BJ17").Value
Case rngD Like Range("BK17").Value
Case rngD Like Range("BL17").Value
Case Else
Meldung1 = Meldung1 & vbLf & rngD.Address
If rngN Is Nothing Then
Set rngN = rngD
Else
Set rngN = Union(rngN, rngD)
End If
End Select
Next
If Meldung1 "" Then
rngN.Select
MsgBox "Wrong Missing Code: " & vbLf & Meldung1
Application.EnableEvents = False
rngN = ""
Application.EnableEvents = True
End If
End If
If Not Intersect(Target, Columns(7)) Is Nothing And Target.Row >= 30 Then
For Each rngC In Intersect(Target, Columns(7))
Select Case True
Case rngC Like ""
Case rngC Like Sheets("DATEN").Range("A252").Value
Case rngC Like Sheets("DATEN").Range("A253").Value
Case rngC Like Sheets("DATEN").Range("A254").Value
Case rngC Like Sheets("DATEN").Range("A255").Value
Case rngC Like Sheets("DATEN").Range("A256").Value
Case rngC Like Sheets("DATEN").Range("A257").Value
Case rngC Like Sheets("DATEN").Range("A258").Value
Case rngC Like Sheets("DATEN").Range("A259").Value
Case rngC Like Sheets("DATEN").Range("A260").Value
Case rngC Like Sheets("DATEN").Range("A261").Value
Case rngC Like Sheets("DATEN").Range("A262").Value
Case rngC Like Sheets("DATEN").Range("A263").Value
Case rngC Like Sheets("DATEN").Range("A264").Value
Case rngC Like Sheets("DATEN").Range("A265").Value
Case rngC Like Sheets("DATEN").Range("A266").Value
Case rngC Like Sheets("DATEN").Range("A267").Value
Case rngC Like Sheets("DATEN").Range("A268").Value
Case rngC Like Sheets("DATEN").Range("A269").Value
Case rngC Like Sheets("DATEN").Range("A270").Value
Case rngC Like Sheets("DATEN").Range("A271").Value
Case rngC Like Sheets("DATEN").Range("A272").Value
Case rngC Like Sheets("DATEN").Range("A272").Value
Case rngC Like Sheets("DATEN").Range("A273").Value
Case rngC Like Sheets("DATEN").Range("A274").Value
Case rngC Like Sheets("DATEN").Range("A275").Value
Case rngC Like Sheets("DATEN").Range("A276").Value
Case rngC Like Sheets("DATEN").Range("A277").Value
Case rngC Like Sheets("DATEN").Range("A278").Value
Case rngC Like Sheets("DATEN").Range("A279").Value
Case rngC Like Sheets("DATEN").Range("A280").Value
Case rngC Like Sheets("DATEN").Range("A281").Value
'Case rngC Like Sheets("DATEN").Range("A282").Value
'Case rngC Like Sheets("DATEN").Range("A283").Value
Case Else
Meldung = Meldung & vbLf & rngC.Address
If rngM Is Nothing Then
Set rngM = rngC
Else
Set rngM = Union(rngM, rngC)
End If
End Select
Next
If Meldung "" Then
rngM.Select
MsgBox "Wrong Missing Code: " & vbLf & Meldung
Application.EnableEvents = False
rngM = ""
Application.EnableEvents = True
End If
End If
End Sub