Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1684to1688
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
Inhaltsverzeichnis

2x automatisch Datum + Farbwechsel

2x automatisch Datum + Farbwechsel
18.04.2019 14:14:24
Micha
Hallo.
Ich habe leider nur Excel und VBA Grundkentnisse, und bin bisher mit Google Copy&Past Codes gut zurecht gekommen.
Allerdings bin ich nun an meine Grenze gekommen, da ich mehrere Worksheet Changes machen muss.
Folgendes soll die Excel können:
Trage ich in Spalte B etwas ein soll diese Gelb werden und in der gleichen Zeile Spalte A (quasi Zelle – 1) das aktuelle Datum erscheinen.
Falls sich danach in Spalte E der Wert ändert, soll in Spalte D der gleichen Zeile wieder das Datum, zusätzlich soll sich dann die Spalte B aus der gleichen Zeile, welche vorher Gelb war automatisch in Grün ändern.

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

Betreff
Datum
Anwender
Anzeige
AW: 2x automatisch Datum + Farbwechsel
18.04.2019 14:35:35
UweD
Hallo
- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Dieses reinkopieren
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Farbe As Long
    On Error GoTo Fehler
    
    'Nur Auslösen bei Änderungen in Spalte B 
    If Not Intersect(Range("B:B"), Target) Is Nothing Then
        
        'nur wenn NICHT Leer 
        If Target <> "" Then
            If Target.Offset(0, -1) = "" Then 'erster Eintrag in Zelle 
                Farbe = 65535 'Gelb 
                
            ElseIf IsDate(Target.Offset(0, -1)) Then 'Nächster Eintrag in Zelle 
                Farbe = 5287936 'Grün 
            End If
        End If
        
        If Farbe <> 0 Then
            'Datum eintragen 
            Application.EnableEvents = False
            Target.Offset(0, -1) = Format(Date, "DD.MM.YYYY")
            Application.EnableEvents = True
            
            'Zelle Färben 
            With Target.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = Farbe
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        Else ' wenn "" 
            
            'Datum löschen 
            Application.EnableEvents = False
            Target.Offset(0, -1).ClearContents
            Application.EnableEvents = True

            ''Zelle ohne Farbe 
            With Target.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

        End If
    End If

'Fehlerbehandlung 
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige
Änderung
18.04.2019 14:42:06
UweD
2. Datum in D hatte ich übersehen
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Farbe As Long, Off As Integer
    On Error GoTo Fehler
    
    'Nur Auslösen bei Änderungen in Spalte B 
    If Not Intersect(Range("B:B"), Target) Is Nothing Then
        
        'nur wenn NICHT Leer 
        If Target <> "" Then
            If Target.Offset(0, -1) = "" Then 'erster Eintrag in Zelle 
                Farbe = 65535 'Gelb 
                Off = -1 ' Spalte A 
                
            ElseIf IsDate(Target.Offset(0, -1)) Then 'Nächster Eintrag in Zelle 
                Farbe = 5287936 'Grün 
                Off = 2 'Spalte D 
            End If
        End If
        
        If Farbe <> 0 Then
            'Datum eintragen 
            Application.EnableEvents = False
            Target.Offset(0, Off) = Format(Date, "DD.MM.YYYY")
            Application.EnableEvents = True
            
            'Zelle Färben 
            With Target.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = Farbe
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        Else ' wenn "" 
            
            'Datum löschen 
            Application.EnableEvents = False
            Target.Offset(0, -1).ClearContents
            Target.Offset(0, 2).ClearContents
            Application.EnableEvents = True

            ''Zelle ohne Farbe 
            With Target.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

        End If
    End If

'Fehlerbehandlung 
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD
Anzeige
AW: 2x automatisch Datum + Farbwechsel
18.04.2019 15:09:39
Micha
Hallo Uwe. Vielen Dank für die Mühe.
Ich habe den Code Probiert. Es funktioniert leider nicht ganz, oder ich habe es falsch beschrieben.
Ich erkläre es so:
In Spalte B kommt mein Artikelname, dann soll Automatisch in Spalte A das Wareneingsdatum von Heute, und Spalte B mit dem Artikelnamen Gelb hinterlegt.
Beim Warenausgang suche ich mir den Artikelname, schreibe in die gleiche Zeile zum Artikel den Kunden an den es ging, also ändere ich Spalte E „Kunde“ und daraufhin soll der Artikelname „Spalte A“ grün hinterlegt sein, und in „Spalte D“ soll das Warenausgangsdatum, also der Tag an dem ich Spalte E,Kunde, ändere. Bei deinem Code kommt nur nach der Änderung in Spalte B das Datum in A, und B ist gelb hinterlegt.
Die Funktion des Warenausgangs ist nicht mit dabei.
Anzeige
AW: 2x automatisch Datum + Farbwechsel
18.04.2019 15:39:29
UweD
Hallo nochmal
ok. so?
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Farbe As Long
    On Error GoTo Fehler
    
    'Nur Auslösen bei Änderungen in Spalte B 
    If Not Intersect(Range("B:B"), Target) Is Nothing Then
        
        'nur wenn NICHT Leer 
        If Target <> "" Then
            
            'Datum eintragen 
            Application.EnableEvents = False
            Target.Offset(0, -1) = Format(Date, "DD.MM.YYYY")
            Application.EnableEvents = True
            
            'Zelle Färben 
            With Target.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 65535 'Gelb 
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
                
        Else
                
            'ggf Datum löschen 
            Application.EnableEvents = False
            Target.Offset(0, -1).ClearContents
            Application.EnableEvents = True
            
            'Zelle ohne Farbe 
            With Target.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

        End If
            
    End If

    
    If Not Intersect(Range("E:E"), Target) Is Nothing Then
        
        'nur wenn NICHT Leer 
        If Target <> "" Then
            
            'Datum eintragen 
            Application.EnableEvents = False
            Target.Offset(0, -1) = Format(Date, "DD.MM.YYYY")
            Application.EnableEvents = True
            
            'Zelle Färben 
            With Target.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 5287936 'Grün 
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
                
        Else
                
            'ggf Datum löschen 
            Application.EnableEvents = False
            Target.Offset(0, -1).ClearContents
            Application.EnableEvents = True
            
            'Zelle ohne Farbe 
            With Target.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

        End If
            
    End If



'Fehlerbehandlung 
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige
AW: 2x automatisch Datum + Farbwechsel
21.04.2019 11:45:40
micha
Hallo Uwe. Vielen Dank ein weiteres mal. Habe den Code eben getestet, und bemerkt das die Zelle in Spalte E selber grün wirde, dabei soll ja die dazugehörige "B Zelle" grün werden.
Ich glaube das kann man via "Target.Offset(0, -3)" lösen, ich versuch es mal.
Eine weitere Frage habe ich noch. Die Tabelle hat ca pro Jahr um die 8000 Spalten, lebt also.
Wenn ich nun einen Artikel "Austragen" will, suche ich ihn künftig über die Excel suche, und nur in den Gelben Feldern, die grünen sind ja schon Ausgebucht.
Ist es möglich eine einfache "Ausbuchung" zu programmieren?
Ich schreibe in ein "Suchfeld" die Artikelnummer, dabei wird in Spalte B nur in den Gelben diese gesucht, und Automatisch in der Spalte E zu diesem Artikel "ABC" eingetragen, daraufhin erfolgt ja nun automatisch in D das Datum und B wird grün. Kann man das irgendwie mit einem Enter Button oder ähnliches automatisieren? Zu 99,9% ist der Kundenname immer "ABC" das heisst falls es mal nicht so ist, würde ich es dann händisch ändern.
Anzeige
AW: 2x automatisch Datum + Farbwechsel
23.04.2019 11:19:45
UweD
Hallo
in ein normales Modul. (das kannst du ja einem Button zuweisen)
Sub Suchen()
    Dim Sp As Integer, Artnum As String
    Dim C As Range, firstAddress As String
    
    Sp = 2 'Spalte B 
    With ActiveSheet.Columns(Sp)
        Artnum = InputBox("Was soll gesucht werden", "Artkelnummer")
        If Artnum <> "" Then
            Set C = .Find(Artnum, LookIn:=xlValues)
            If Not C Is Nothing Then
                firstAddress = C.Address
                Do
                    C.Offset(0, 3) = "ABC"
                    
                    Set C = .FindNext(C) 'finde das Nächste 
                Loop While Not C Is Nothing And C.Address <> firstAddress
            End If
        Else
            MsgBox "Keine Auswahl"
        End If
    
    End With
End Sub

LG UweD
Anzeige
AW: 2x automatisch Datum + Farbwechsel
23.04.2019 11:26:08
UweD
Sub Suchen()
    Dim Sp As Integer, Artnum As String
    Dim C As Range, firstAddress As String
    
    Sp = 2 'Spalte B 
    With ActiveSheet.Columns(Sp)
        Artnum = InputBox("Was soll gesucht werden", "Artkelnummer")
        If Artnum <> "" Then
            Set C = .Find(Artnum, LookIn:=xlValues)
            If Not C Is Nothing Then
                firstAddress = C.Address
                Do
                    If C.Offset(0, 3) = "" Then
                        C.Offset(0, 3) = "ABC"
                    End If
                    
                    Set C = .FindNext(C) 'finde das Nächste 
                Loop While Not C Is Nothing And C.Address <> firstAddress
            Else
                MsgBox "Kein Fund"
            End If
        Else
            MsgBox "Keine Auswahl"
        End If
    
    End With
End Sub

zusätzlich prüfen, ob schon "Ausgebucht ist" eingebaut
LG UweD
Anzeige
AW: 2x automatisch Datum + Farbwechsel
21.04.2019 11:44:51
micha
Hallo Uwe. Vielen Dank ein weiteres mal. Habe den Code eben getestet, und bemerkt das die Zelle in Spalte E selber grün wirde, dabei soll ja die dazugehörige "B Zelle" grün werden.
Ich glaube das kann man via "Target.Offset(0, -3)" lösen, ich versuch es mal.
Eine weitere Frage habe ich noch. Die Tabelle hat ca pro Jahr um die 8000 Spalten, lebt also.
Wenn ich nun einen Artikel "Austragen" will, suche ich ihn künftig über die Excel suche, und nur in den Gelben Feldern, die grünen sind ja schon Ausgebucht.
Ist es möglich eine einfache "Ausbuchung" zu programmieren?
Ich schreibe in ein "Suchfeld" die Artikelnummer, dabei wird in Spalte B nur in den Gelben diese gesucht, und Automatisch in der Spalte E zu diesem Artikel "ABC" eingetragen, daraufhin erfolgt ja nun automatisch in D das Datum und B wird grün. Kann man das irgendwie mit einem Enter Button oder ähnliches automatisieren? Zu 99,9% ist der Kundenname immer "ABC" das heisst falls es mal nicht so ist, würde ich es dann händisch ändern.
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige