Inhalte in Spalte D löschen

Option Compare Text ' Bei Vergleichen Groß-/Kleinschreibung nicht beachten
Option Explicit

Dim busy As Boolean

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Bereich1 As Range, Bereich2 As Range, Bereich3 As Range
Dim c As Range
Dim col As Integer
Dim AK As String
Application.Calculation = xlCalculationAutomatic
If busy Then Exit Sub ' zum Verhindern des Selbstaufrufens durch VBA-geänderte Zellen

Set Bereich1 = Range("D2:D1000")
Set Bereich2 = Range("E2:E1000")
Set Bereich3 = Range("I2:I1000")

If Intersect(Target, Bereich1) Is Nothing And Intersect(Target, Bereich2) Is Nothing _
And Intersect(Target, Bereich3) Is Nothing Then Exit Sub

busy = True
Application.ScreenUpdating = False

For Each c In Target

If Not (Intersect(c, Bereich1) Is Nothing) Then

If c.Value = "m" Then
col = 2
ElseIf c.Value = "w" Then
col = 3
Else
c.Select
Application.ScreenUpdating = True
MsgBox "Falscher Wert"
Application.ScreenUpdating = False
col = 0
End If

ElseIf Not (Intersect(c, Bereich2) Is Nothing) Then

If Cells(c.Row, 4) = "m" Then
col = 2
ElseIf Cells(c.Row, 4) = "w" Then
col = 3
Else
col = 0
End If

ElseIf Not (Intersect(c, Bereich3) Is Nothing) Then

If (Len(c) > 6 Or InStr(c, " ") <> 0 Or InStr(c, ".") <> 0) Then
c.Select
Application.ScreenUpdating = True
MsgBox "Unzulässiger Wert"
Application.ScreenUpdating = False
End If
col = -1 ' Verhindern des Beschreibens der "AK"-Spalte

End If

If col > 0 Then
AK = ""
On Error Resume Next
AK = Application.WorksheetFunction.VLookup(Cells(c.Row, 5), _
Worksheets("Klasseneinteilung").Range("B2:D150"), col, False)
On Error GoTo 0
Cells(c.Row, 6) = AK
ElseIf col = 0 Then
Cells(c.Row, 6) = ""
End If

Next c
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
busy = False

End Sub

Vielen Dank für eure Hilfe!

Tschüß
Rolf