Herbers Excel-Forum - das Archiv

Überprüfung von Zellen mit Worksheet change

Bild

Betrifft: Überprüfung von Zellen mit Worksheet change
von: Bernd Cramer

Geschrieben am: 14.05.2008 07:47:44

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 < Cells(zeile, 12).Value Then
Cells(zeile, 7).Interior.ColorIndex = 4
Else
Cells(zeile, 7).Interior.ColorIndex = 0
End If
Else
Cells(zeile, 7).Interior.ColorIndex = 0
End If
Else
Cells(zeile, 7).Interior.ColorIndex = 0
End If
If Cells(zeile, 6).Value <> "" Then
If Cells(zeile, 6).Value > 0 Then
If Cells(zeile, 6).Value < Cells(zeile, 12).Value Then
Cells(zeile, 9).Interior.ColorIndex = 4
Else
Cells(zeile, 9).Interior.ColorIndex = 0
End If
Else
Cells(zeile, 9).Interior.ColorIndex = 0
End If
Else
Cells(zeile, 9).Interior.ColorIndex = 0
End If
Next
End If
Range("H4:O" & introw2).Columns.AutoFit
End Sub


Bild

Betrifft: AW: Überprüfung von Zellen mit Worksheet change
von: Reinhard

Geschrieben am: 14.05.2008 16:11:17
Hi Bernd,
benutze Option Explicit.
Zeilen immer als Long deklarieren.
Jede Variable braucht ein eigenes As, so wie du es beim ersten Dim getan hast.
Setze Hochkamma vor On Error resume next dann springt der Debugger sicher zu
Cells(zeile,3)...
da es keine Zelle C0 gibt
Tausche
introw2 = Trim(Str(Range("a65536").End(xlUp).Row))
gegen
lngRow2 = Range("a" & Rows.count).End(xlUp).Row
Tausche

For zeile = 5 To introw2
If Cells(zeile, 3).Value <> "" Then
If Cells(zeile, 3).Value > 0 Then
If Cells(zeile, 3).Value < Cells(zeile, 12).Value Then
Cells(zeile, 7).Interior.ColorIndex = 4
Else
Cells(zeile, 7).Interior.ColorIndex = 0
End If
Else
Cells(zeile, 7).Interior.ColorIndex = 0
End If
Else
Cells(zeile, 7).Interior.ColorIndex = 0
End If


gegen

Cells(zeile, 7).Interior.ColorIndex = xlNone
For zeile = 5 To introw2
If Cells(zeile, 3).Value > 0 Then
If Cells(zeile, 3).Value < Cells(zeile, 12).Value Then Cells(zeile, 7).Interior. _
ColorIndex = 4
End If


Tausche

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


gegen

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


Und mache alle Änderungen Stück für Stück und immer wieder zwischendurch testen, nicht alles auf einmal ändern!
Gruß
Reinhard

 Bild
Excel-Beispiele zum Thema "Überprüfung von Zellen mit Worksheet change"
Makros in Abhängigkeit vom Zellennamen aufrufen Zellen auf Kommentar überprüfen
Spalten bedingt summieren und Zellen formatieren Text aus Textbox in Zellen aufteilen
Zellen vergleichen und markieren Zählen formatierter Zellen
Daten aus Textdatei gezielt in Zellen übernehmen Zellen verbinden und trennen
Zellen bei Minuswerten schraffieren Zeilen oberhalb der markierten Zellen einfügen