Re: Zelle überschreiben
08.06.2002 20:49:08
Rolf
Hallo Hajo,
dein Makro funktioniert super, leider vergaß ich zu sagen, dass die Tabelle schon Makros enthält und ich zu dumm bin es einzufügen.
Kannst du mir noch einmal helfen?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
' ActiveSheet.Unprotect ("laufen")
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
' ActiveSheet.Protect ("laufen")
Application.ScreenUpdating = True
busy = False
End Sub
' ab hier Makro von Hajo
Public Wert
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("F1:F1000")
If Not Intersect(Target, Bereich) Is Nothing Then ' Zelle ist im Bereich
Application.EnableEvents = False
Target.Value = Wert
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("F1:F1000")
If Not Intersect(Target, Bereich) Is Nothing Then ' Zelle ist im Bereich
Wert = Target.Value
End If
End Sub
Vielen Dank!
Tschüß
Rolf