Microsoft Excel

Herbers Excel/VBA-Archiv

Überprüfung von Zellen mit Worksheet change

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


  

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


 

Beiträge aus den Excel-Beispielen zum Thema "Überprüfung von Zellen mit Worksheet change"