Ich möchte die Inhalte in Spalte D löschen.
Ist es möglich, das mir jemand folgendes Makro so ändert, das
nicht bei jeder, gelöschten Zelle die Meldung "falscher Wert kommt" ?
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.EnableEvents = False
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
Application.EnableEvents = True
busy = False
End Sub
Vielen Dank für eure Hilfe!
Tschüß
Rolf