OldValue <> NewValue im Loop

Private Sub Worksheet_Change(ByVal Target As Range) Dim KeyCells As Range, vNew, vOld For Each c In Target.Cells Set KeyCells = Range("A1:AO1") If Not Application.Intersect(KeyCells, Target) Is Nothing Then vNew = Target.Value Application.EnableEvents = False Application.Undo vOld = Target.Value Target.Value = vNew Application.EnableEvents = True If StrConv(vNew, vbLowerCase) StrConv(vOld, vbLowerCase) Then Call Modul1.TabName1 Call Modul2.Email_Tabelle1 End If End If Next End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim v As Variant, x As Long, C As Range If Not Intersect(Target, Range("A1:AO1")) Is Nothing Then ReDim v(1 To Intersect(Target, Range("A1:AO1")).Cells.Count, 1 To 2) For Each C In Intersect(Target, Range("A1:AO1")) x = x + 1 v(x, 1) = C.Value v(x, 2) = C.Address Next Application.EnableEvents = False Application.Undo Application.EnableEvents = True For x = LBound(v, 1) To UBound(v, 1) If LCase(v(x, 1)) LCase(Range(v(x, 2))) Then MsgBox "Houston Calling" 'Call Modul1.TabName1 'Call Modul2.Email_Tabelle1 Exit For 'ggf. damit Wiederholung unterbleibt! End If Next End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim v As Variant, x As Long, C As Range, b As Boolean If Not Intersect(Target, Range("A1:AO1")) Is Nothing Then ReDim v(1 To Intersect(Target, Range("A1:AO1")).Cells.Count, 1 To 2) For Each C In Intersect(Target, Range("A1:AO1")) x = x + 1 v(x, 1) = C.Value v(x, 2) = C.Address Next Application.EnableEvents = False Application.Undo For x = LBound(v, 1) To UBound(v, 1) If LCase(v(x, 1)) LCase(Range(v(x, 2))) Then If Range(v(x, 2)) "" Then b = True End If Range(v(x, 2)) = v(x, 1) Next Application.EnableEvents = True If b = True Then MsgBox "Houston Calling" 'Call Modul1.TabName1 'Call Modul2.Email_Tabelle1 End If End If End Sub

Hallo Gerd
Das hat das Problem behoben! Du bist grossartig. Jetzt schäme ich mich fast zu sagen, dass sich ein letztes kleines Problem ergeben hat. Meine Daten werden von einem anderen VBA Code von einem anderen Workbook in dieses Workbook kopiert. Das verwirrt aber die Application.Undo Funktion, die dann Gelb markiert wird. Ich vermute, weil diese dann den Copy Paste Code rückgängig machen möchte. Denn wenn man einen manuellen Copy Paste Vorgang durchführt, funktioniert er jetzt tadellos. Der Code für den Copy Paste Vorgang habe ich untenstehend hinzugefügt. Übrigens Gerd, du hilfst mir hier völlig uneigennützig mit einem grossen Problem. Ist es also in irgendeiner Form erlaubt, dir per Twint einen kleinen Betrag zu überweisen oder irgendetwas in dieser Richtung. Alleine hätte ich die Lösung nämlich nie gefunden.
Liebe Grüsse
David
Sheets("Gruppenplanung").Select
Range("A2").Select
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.Range("A2").AutoFilter Field:=19, Criteria1:="SG 3", Operator:=xlAnd
Rows("3:100").Select
Selection.Copy
Workbooks.Open "R:\BINplus\Langenthal\Stammgruppen\Stammgruppe 3\Stammgruppe 3_Unterrichtspläne Test.xlsm"
Worksheets("Stammdaten").Range("A1").PasteSpecial
Workbooks("Stammgruppe 3_Unterrichtspläne Test.xlsm").Close SaveChanges:=True
End Sub

Option Explicit 'Ins Modul DieseArbeitsmappe; Blattname ggf. anpassen! Private Sub Workbook_Open() Dim lngCol As Long ReDim vntValues(1 To 41) For lngCol = 1 To 41 vntValues(lngCol) = Worksheets("Tabelle1").Cells(1, lngCol).Value Next End Sub

Option Explicit 'Ins Modul der zu überwachendenTabelle Private Sub Worksheet_Change(ByVal Target As Range) Const RefAdr = "A1:AO1" Dim objCell As Range, blnCheck As Boolean If Not Intersect(Range(RefAdr), Target) Is Nothing Then Application.EnableEvents = False For Each objCell In Intersect(Range(RefAdr), Target) If Not IsEmpty(vntValues(objCell.Column)) Then If vntValues(objCell.Column) objCell.Value Then vntValues(objCell.Column) = objCell.Value blnCheck = True End If End If Next End If Application.EnableEvents = True If blnCheck Then MsgBox "Houston Calling" 'Call Modul1.TabName1 'Call Modul2.Email_Tabelle1 End If End Sub

Hallo Gerd
Einfach nur beeindruckend. Das funktioniert perfekt! Ich versuche gerade noch alle Zeilen in diesem Code zu verstehen, um ihn für mehrere Zeilen zu multiplizieren. Indem ich Const RefAdr1 und RefAdr2 definiere gelingt mir das eigentlich auch. Jedoch werden die Module für die Range A2:AO2 immer ausgelöst, auch wenn die Daten, die überschrieben wurden, dieselben wie davor sind. Untenstehend habe ich meinen Laienhaften Versuch mitgeschickt. Kannst du mir noch ein letztes Mal helfen:)?
Ich finde es beispiellos solidarisch von dir, so etwas "just for fun" zu machen. Schon faszinierend, dass hier auf dem Forum scheinbar etwas gelebt wird, was im restlichen Internet ausgestorben scheint. Ich werde sehr gerne etwas über die entsprechende IBAN spenden, um die Opfern der Hochwasserkatastrophe zu unterstützen.
Gruss David


Private Sub Worksheet_Change(ByVal Target As Range)
Const RefAdr1 = "A1:AO1"
Const RefAdr2 = "A2:AO2"
Dim objCell As Range, blnCheck As Boolean
If Not Intersect(Range(RefAdr1), Target) Is Nothing Then
Application.EnableEvents = False
For Each objCell In Intersect(Range(RefAdr1), Target)
If Not IsEmpty(vntValues(objCell.Column)) Then
If vntValues(objCell.Column)  objCell.Value Then
vntValues(objCell.Column) = objCell.Value
blnCheck = True
End If
End If
Next
End If
Application.EnableEvents = True
If blnCheck Then
Call Modul1.TabName1
Call Modul2.Email_Tabelle1
End If
If Not Intersect(Range(RefAdr2), Target) Is Nothing Then
Application.EnableEvents = False
For Each objCell In Intersect(Range(RefAdr2), Target)
If Not IsEmpty(vntValues(objCell.Column)) Then
If vntValues(objCell.Column)  objCell.Value Then
vntValues(objCell.Column) = objCell.Value
blnCheck = True
End If
End If
Next
End If
Application.EnableEvents = True
If blnCheck Then
Call Modul1.TabName2
Call Modul2.Email_Tabelle2
End If
End Sub

'In ein allgemeines Modul, z.B. Modul1 Option Explicit Public vntValues As Variant 'Ins Modul DieseArbeitsmappe; Blattname u. Bereich ggf. anpassen! Option Explicit Private Sub Workbook_Open() Dim X As Range With Worksheets("Tabelle1").Range("A1:AO2") ReDim vntValues(.Row To .Rows.Count - .Row + 1, .Column To .Columns.Count - .Column + 1) For Each X In .Cells vntValues(X.Row, X.Column) = X.Value Next End With End Sub 'Ins Modul der zu überwachenden Tabelle Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Const RefAdr = "A1:AO2" Dim objCell As Range, blnCheck As Boolean, Z As Long, S As Long If Not Intersect(Range(RefAdr), Target) Is Nothing Then Application.EnableEvents = False For Each objCell In Intersect(Range(RefAdr), Target) Z = objCell.Row S = objCell.Column If vntValues(Z, S) objCell.Value Then If Not IsEmpty(vntValues(Z, S)) Then blnCheck = True End If vntValues(Z, S) = objCell.Value Next End If Application.EnableEvents = True If blnCheck Then MsgBox "Houston Calling" 'Call Modul1.TabName1 'Call Modul2.Email_Tabelle1 End If End Sub

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

OldValue <> NewValue im Loop

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread