Code auf ganze Spalte erweitern

Private Sub Worksheet_Change(ByVal Target As Range) Dim Zelle As Range Dim Dif As Long Dim Ur As Long Dim Ver As Long Ur = ThisWorkbook.Worksheets("Artikel").Cells(ActiveCell.Row, 5) Ver = ThisWorkbook.Worksheets("Artikel").Cells(ActiveCell.Row, 22) If Target.Address = "$V$15" Then If ThisWorkbook.Worksheets("Artikel").Cells(ActiveCell.Row, 22) ThisWorkbook. _ Worksheets("Artikel").Cells(ActiveCell.Row, 5) Then Dif = Ur - Ver ActiveCell.Offset(0, -1).EntireRow.Copy Cells(ActiveCell.Row + 1, 1).Insert Shift:=xlDown Cells(ActiveCell.Row + 1, 1).Select ThisWorkbook.Worksheets("Artikel").Cells(ActiveCell.Row, 5) = Dif ThisWorkbook.Worksheets("Artikel").Cells(ActiveCell.Row, 22) = "" End If End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Oisse,
die ganzen "this" und "active" sind geschenkt, weil sich diese Art von Ereignissen IMMER auf das jeweilige Blatt beziehen.
Dann könnte es etwa so aussehen:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 3 And Target.Column = 22 Then
If Target  "" Then
If IsNumeric(Target.Value) Then
If Target.Value  Target.Offset(, -17).Value And _
Target.Value  0 Then
If Target.Offset(1, -21).Value  Target.Offset(, -21).Value Then
Application.EnableEvents = False
Target.EntireRow.Copy
Target.Offset(1, -21).Insert
Target.Offset(1, -17).Value = Target.Offset(, -17).Value - Target.Value
Target.Offset(1).Value = ""
Application.EnableEvents = True
Application.CutCopyMode = False
Else
MsgBox "bitte weiter unten ändern"
End If
End If
End If
End If
End If
End Sub

Im Beispiel bin ich davon ausgegangen, daß die Artikel in Spalte A stehen, die ergibt sich in der Abfrage nach:

Target.Offset(1, -17).Value = Target.Offset(, -17).Value - Target.Value

Wenn die Zeile unter der Eingabe bereits der gleiche Artikel ist, wird die Aktion NICHT ausgeführt, weil sie ja logischerweise immer in der UNTERSTEN, vorhandenen Zeile zu diesem Artikel passieren sollte, sonst müßte man alle Werte unten neu durchkalkulieren...
Das hat allerdings den Pferdefuß, daß der falsche Wert in der Zelle stehenbleibt.
Das wiederum läßt sich durch diese 3 Zeilen direkt nach der MsgBox beheben:

              Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True

Schöne Grüße,
Michael

Private Sub Worksheet_Change(ByVal Target As Range) Dim Dif As Long Dim Ur As Long Dim Ver As Long Ur = Cells(Target.Row, 5) Ver = Cells(Target.Row, 22) If Target.Row > 2 And Target.Column = 22 Then If Cells(Target.Row, 22) Cells(Target.Row, 5) Then Dif = Ur - Ver Application.EnableEvents = False Target.EntireRow.Copy Target.Offset(1, 0).EntireRow.Insert shift:=xlDown Target.Offset(1, -17) = Dif Target.Offset(1, 0) = "" Application.EnableEvents = True Application.CutCopyMode = False End If End If End Sub

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code auf ganze Spalte erweitern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread