Überprüfung von Zellen mit Worksheet change

Mit folgendem Code überprüfe ich Zellen in der Spalte C und Spalte F nach Veränderungen in der Tabelle. Normalerweise befindet sich dort eine Formel die einen Wert aus G und J für Spalte C, oder I und J für Spalte F errechnet. Es kann aber passieren, das in eine Zelle der Spalten C und F der Wert direkt eingetippt wird. In diesem Fall errechnen die ersten beiden For each .. next Schleifen den Prozentwert, der dann in dazugeörige Zeile der Spalte G für C oder I für F eingetragen wird. Dies funktioniert auch problemlos, nur bei größeren Tabellen dauert die Berechnung eben.
Die dritte Schleife vergleicht die Werte der Spalten C und F zeilenweise mit einem jemweils zugehörigen Grenzwert. Bei Unterschreitung dessen werden die entsprechenden Zellen in den Spalten g und i rot markiert.
Nun überlege ich wie ich diese aufwendige Prozedur einfacher und damit schneller gestalten kann. Kann mir jemend ein paar Tips geben?
Gruß aus Halle
Bernd Cramer


Private Sub Worksheet_Change(ByVal Target As Range)
Dim ber_0 As Range, ber_1 As Range, ber_2 As Range
Dim zeile, start, sprung As Integer
Dim test, adr, forml As String
Dim zelle1, zelle2 As Double
On Error Resume Next
If kopie = 0 Then
Application.DisplayAlerts = False
introw2 = Trim(Str(Range("a65536").End(xlUp).Row))
adr = "C5:C" + introw2
Set ber_0 = Range("C5:C" & introw2)
If Not Intersect(Target, ber_0) Is Nothing Then
For Each ber_1 In ber_0
Set ber_2 = ber_1.Offset(0, 7) 'gleiche Zeile aber Spalte J
If IsNumeric(ber_1.Value) And (""  ber_1.Value) Then
If Not ber_1.HasFormula Then
If ""  ber_2.Value Then
zelle1 = ber_1.Value
zelle2 = ber_2.Value
zelle1 = 1 - (zelle1 / zelle2)
ber_1.Offset(0, 4).Value = zelle1 'gleiche Zeile aber Spalte G
End If
End If
End If
Next
End If
Set ber_0 = Nothing
Set ber_1 = Nothing
Set ber_2 = Nothing
adr = "F5:F" + introw2
Set ber_0 = Range("F5:F" & introw2)
If Not Intersect(Target, ber_0) Is Nothing Then
For Each ber_1 In ber_0
Set ber_2 = ber_1.Offset(0, 4) 'gleiche Zeile aber Spalte J
If IsNumeric(ber_1.Value) And (""  ber_1.Value) Then
If Not ber_1.HasFormula Then
If ""  ber_2.Value Then
zelle1 = ber_1.Value
zelle2 = ber_2.Value
zelle1 = 1 - (zelle1 / zelle2)
ber_1.Offset(0, 3).Value = zelle1 'gleiche Zeile aber Spalte I
End If
End If
End If
Next
End If
Set ber_0 = Nothing
Set ber_1 = Nothing
Set ber_2 = Nothing
Application.DisplayAlerts = True
Cells(zeile, 3).Interior.ColorIndex = xlColorIndexNone
Cells(zeile, 6).Interior.ColorIndex = xlColorIndexNone
For zeile = 5 To introw2
If Cells(zeile, 3).Value  "" Then
If Cells(zeile, 3).Value > 0 Then
If Cells(zeile, 3).Value  "" Then
If Cells(zeile, 6).Value > 0 Then
If Cells(zeile, 6).Value

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

For Each ber_1 In ber_0 Set ber_2 = ber_1.Offset(0, 4) 'gleiche Zeile aber Spalte J If IsNumeric(ber_1.Value) And ("" ber_1.Value) Then If Not ber_1.HasFormula Then If "" ber_2.Value Then zelle1 = ber_1.Value zelle2 = ber_2.Value zelle1 = 1 - (zelle1 / zelle2) ber_1.Offset(0, 3).Value = zelle1 'gleiche Zeile aber Spalte I End If End If End If Next

For Each ber_1 In ber_0 With ber_1 If IsNumeric(.Value) Then If Not .HasFormula Then If "" .Offset(0, 4).Value Then .Offset(0, 3).Value = 1 - (.Value / . _ Offset(0, 4).Value) 'gleiche Zeile aber Spalte I End If End If End With Next

Beliebteste Forumthreads (12 Monate)

Überprüfung von Zellen mit Worksheet change

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Überprüfung von Zellen mit Worksheet change

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread