Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1564to1568
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1564to1568
1564to1568
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Worksheet_Change erweitern

Worksheet_Change erweitern
04.07.2017 14:22:26
Paul
Hallo, 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim loLetzte1 As Long
With Worksheets("Abgeschlossene Aufgaben")
loLetzte1 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End With
If Target.Count > 1 Then Exit Sub
If Target.Column = 5 Then
If Target.Row > 1 Then
If Target.Value = "Erledigt" Then
If Target.Offset(, 1) = "" Then
MsgBox "Wann erledigt?"
Target = ""
Target.Offset(, 1).Select
Else
Target.EntireRow.Copy Worksheets("Abgeschlossene Aufgaben").Rows(loLetzte1)
Target.EntireRow.Delete shift:=xlUp
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 7) = ActiveSheet.Name
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 4).Copy
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 7).PasteSpecial  _
xlFormats
Application.CutCopyMode = False
End If
End If
End If
End If
End Sub

Das ist im Moment in meinem Arbeitsblatt. In Spalte 5 wird geprüft, ob da "Erledigt" drin steht und dann wird die komplette Zeile in ein neues Arbeitsblatt kopiert, funktioniert super.
Das würde ich nun gerne um Folgendes erweitern, wenn in Spalte 2 das Fälligkeitsdatum weniger als 30 Tage vom heutigen Datum entfernt ist, soll die Zeile in Spalte 5 dann automatisch in Rot eingefärbt werden und der Text "Dringend" erscheinen.
Könnte mir Jemand diesbezüglich weiterhelfen? Ich bin mit VBA nicht sonderlich bewandert.
Vielen Dank.
Gruß
Paul

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
So z.B.
04.07.2017 15:33:26
Max2
Hallo,
mit unten stehendem Sub kann man das z.B. machen, oder eben mit Formeln und Bedingter Formatierung
Sub kritisch()
Dim ws As Worksheet
Dim rng As Range, c
Dim cRow As Long
Dim today As Date
today = Date
Set ws = ThisWorkbook.Sheets(1)
With ws
cRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rng = .Range(.Cells(1, 2), .Cells(cRow, 2))
Application.ScreenUpdating = False
For Each c In rng
If c
Und hier mit Worksheet_Change "Syntax": 
If Traget.Column = 2 Then
If Target.Value

AW: So z.B.
04.07.2017 15:51:33
Paul
Hallo Max,
vielen, aber ich bekomme es nicht zum Laufen. Wo genau muss die Sub rein? Ich hab es übrigens mit der Formel und bedingter Formatierung probiert und die Formel hat auch soweit funktioniert, aber hatte den Nachteil, dass ich bei neune Datensätzen erst mal immer auf das + klicken musste, um diese zu erweitern und das will ich eigentlich meiden. Es soll bei neuen Datensätzen automatisch.
Anzeige
AW: So z.B.
04.07.2017 20:44:19
Max2
Hallo,
ich biete dir jetzt 2 Versionen.
Hier ist deine Version erweitert: 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim loLetzte1 As Long
Dim today As Date: today = Date
With Worksheets("Abgeschlossene Aufgaben")
loLetzte1 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End With
If Target.Count > 1 Then Exit Sub
If Target.Column = 5 Then
If Target.Row > 1 Then
If Target.Value = "Erledigt" Then
If Target.Offset(, 1) = "" Then
Application.EnableEvents = False
MsgBox "Wann erledigt?"
Target = ""
Target.Offset(, 1).Select
Application.EnableEvents = False
Else
Application.EnableEvents = False
Target.EntireRow.Copy Worksheets("Abgeschlossene Aufgaben").Rows(loLetzte1)
Target.EntireRow.Delete shift:=xlUp
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 7) = ActiveSheet.Name
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 4).Copy
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 7).PasteSpecial _
xlFormats
Application.CutCopyMode = False
Application.EnableEvents = False
End If
End If
End If
End If
If Target.Column = 2 Then
If Target.Value
Hier ist meine Version mit Kommentaren: 

Option Explicit
'//hier färben wir die Werte ein
Private Sub ColorTarget(ByVal Target As Range)
Dim today As Date
'//das heutige Datum
today = Date
'//ist das Datum im kritischen Bereich?
If Target.Value
Verwende den Code, den du besser verstehst, mein Code ist kommentiert,
aber die Kommentare gelten auch für deinen Code, da kein großer unterschied
besteht.
Wenn du fragen hast, oder irgendwas wissen möchtest, dann sag bescheid.
Ich möchte noch vorwarnen das ich die beiden Codes NICHT! getestet habe.
Anzeige
AW: So z.B.
05.07.2017 09:38:48
Paul
Hallo Max,
vielen Dank für die umfassende Rückmeldung. Ich habe nun die erste Variante getestet und es funktioniert wunderbar. Jedoch fällt mir auf, dass ich diese wohlmöglich durch eine Else Bedingung erweitern müsste, denn wenn er Spalte 5 einmal Rot färbt und da Dringend reinschreibt, man aber das Fälligkeitsdatum ändert, passiert nichts und es bleibt rot.
Außerdem fällt mir gerade auf, dass es doch wohlmöglich sinnvoller ist, dies nicht in einer "Workbook_Change" Sub, sondern in einer "Worksheet_Activate" Prozedur unterzubringen, denn das Datum steht bei den jetzt vorhandenen Datensätzen bereits drin und dann passiert ja bei der o.g. Variante erst mal nichts, bis man es ändert.
Ich versuche mal, dies selbst umzusetzen. Falls ich es nicht hinbekomme, würde mich gerne wieder an Dich wenden.
Vielen Dank.
Gruß
Paul
Anzeige
AW: So z.B.
05.07.2017 11:35:14
Max2
Alles klar,
wünsche dir viel Erfolg und Spaß!
AW: So z.B.
05.07.2017 13:43:46
Paul
Hi Max,
muss mich dann doch wieder an Dich wenden, da ich leider nicht gerade VBA-Crack bin ;) Ich kriege es aber einfach nicht hin. Also die Else-Bedingung funktioniert, aber ich krieg den zweiten Teil nicht hin, dass er es ausführt, wenn ich die Tabelle öffne bzw. auf das Tabellenblatt wechsle.
Ich habe es folgendermaßen probiert:
Private Sub Worksheet_Activate(ByVal Target As Range)
Dim today As Date: today = Date
If Target.Column = 2 Then
If Target.Value
oder auch in die Arbeitsmappe:
Private Sub Workbook_Open(ByVal Target As Range)
Dim today As Date: today = Date
If Target.Column = 2 Then
If Target.Value
Es funktioniert beides nicht. Scheint etwas mit ByVal und Target zu sein. Kannst du mir auf die Sprünge helfen, wo der Fehler denn liegt?
Gruß
Paul
Anzeige
AW: So z.B.
05.07.2017 14:04:33
Max2
Hallo,
im activate Event, kannst du nicht den gleichen Code benutzen wie im Change Event, da
die Events ganz anders agieren und völlig unabhängig von einander aktiviert werden.
Hier ist die Lösung mit Activate und nochmals mit Change: 
Private Sub Worksheet_Activate()
Dim ws As Worksheet
Dim rng As Range, c
Dim cRow As Long
Dim today As Date
today = Date
Set ws = ThisWorkbook.Sheets(1)
With ws
cRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rng = .Range(.Cells(1, 2), .Cells(cRow, 2))
Application.ScreenUpdating = False
For Each c In rng
If c.Value  "" Then
If c = today + 30 Then
c.Offset(, 3).Interior.ColorIndex = xlNone
End If
End If
Next
Application.ScreenUpdating = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim loLetzte1 As Long
Dim today As Date: today = Date
With Worksheets("Abgeschlossene Aufgaben")
loLetzte1 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End With
If Target.Count > 1 Then Exit Sub
If Target.Column = 5 Then
If Target.Row > 1 Then
If Target.Value = "Erledigt" Then
If Target.Offset(, 1) = "" Then
Application.EnableEvents = False
MsgBox "Wann erledigt?"
Target = ""
Target.Offset(, 1).Select
Application.EnableEvents = False
Else
Application.EnableEvents = False
Target.EntireRow.Copy Worksheets("Abgeschlossene Aufgaben").Rows(loLetzte1)
Target.EntireRow.Delete shift:=xlUp
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 7) = ActiveSheet. _
Name
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 4).Copy
Worksheets("Abgeschlossene Aufgaben").Cells(loLetzte1, 7).PasteSpecial _
xlFormats
Application.CutCopyMode = False
Application.EnableEvents = False
End If
End If
End If
End If
If Target.Column = 2 Then
If Target.Value  "" Then
If Target.Value = today + 30 Then
Target.Offset(, 3).Interior.ColorIndex = xlNone
Target.Offset(, 3).Value = ""
End If
End If
End If
End Sub

Anzeige
AW: So z.B.
05.07.2017 15:30:05
Paul
Besten Dank! Hab nun beides genommen, dass er bei Change und bei Activate die Ereignisse ausführt, klappt soweit super.
Gruß
Paul
AW: So z.B.
05.07.2017 16:14:36
Paul
Hey Max,
sorry, ich muss Dich wieder stören :) Ich habe nun folgendes Problem festgestellt. Wenn ich das Datum so ändere, dass das größer ist als HEUTE + 30 dann soll in Spalte 3 ja keine Farbe drin und auch kein Text "Dringend". Das funktioniert auch, aber in Spalte 5 wird dann auch die Überschrift gelöscht, die ich in Zeile 1 der Spalte 5 habe, z.B. "Status". Jedes Mal, wenn ich es ändere, dann löscht er die Formatierung der Spalte 5 / Zeile 1. Wie krieg ich das Problem gelöst?
Gruß
Paul
Anzeige
AW: So z.B.
06.07.2017 08:01:45
Max2
Hallo,
das müsste am Fett markierten liegen: 

Private Sub Worksheet_Activate()
Dim ws As Worksheet
Dim rng As Range, c
Dim cRow As Long
Dim today As Date
today = Date
Set ws = ThisWorkbook.Sheets(1)
With ws
cRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rng = .Range(.Cells(1, 2), .Cells(cRow, 2))
Application.ScreenUpdating = False
For Each c In rng
If c.Value  "" Then
If c = today + 30 Then
c.Offset(, 3).Interior.ColorIndex = xlNone
End If
End If
Next
Application.ScreenUpdating = True
End With
End Sub
ändere das mal ab in : 
rng = .Range(.Cells(2, 2), .Cells(cRow, 2))

Anzeige
AW: So z.B.
06.07.2017 08:43:33
Paul
Hallo,
danke. Und der Change Sheet müsste vermutlich unten If.Target.Row größer als 1 ergänzt werden, oder?
Grüße
AW: So z.B.
06.07.2017 11:10:01
Max2
Yes, da hast du recht.
Am sinnvollsten wäre es aber, beim Change Event, gleich am Anfang zu prüfen.
Also: If Target.Row = 1 Then Exit Sub
Somit verhinderst du, das der Code weitermacht/startet wenn du in der ersten Zeile bist.

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige