Office: (Office Version unbekannt) Wert in B suchen und in H Datum

Hallo zusammen und einen guten Abend

Ich hänge mal wieder fest.

Ich bin auf der suche nach einem Code der mir in Spalte B einen Wert sucht den ich in N5 eigebe.
Wenn der Wert gefunden wurde soll in H das aktuelle Datum rein.

Der gefunde Wert steht in B8 dann soll in H8 das Datum rein.


Ich habe gesucht und versucht aber bis her bin ich nicht weiter gekommen.


Gruß Michael


Leider habe ich erst später hier einen Beitrag der dem Problem sehr nahe kommt gefunden. Aber leider hilft mir das nicht viel weiter.

 

Ich habe habe nun folgendes versucht.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim rng1 As Range
Dim Zeile As Long


Set rng1 = ActiveSheet.Range("N5")
Set rng = ActiveSheet.Range("B5:B35").Find(rng1)
If rng Is Nothing Then
MsgBox "Fehler"
Exit Sub
End If
rng.Offset(0, 6).Value = Date
'MsgBox "Zeile: " & rng.Row & "; Adresse: " & rng.Address

End Sub

Es wird gesucht es wird auch gefunden und geändert nur dann kommt ein Laufzeitfehler.

Wenn ich den Code so rein mache und über einen Button starte klappt es ohne Fehler.

Kann mir da mal bitte jemand helfen.


Gruß Michael

 

Hallo Michael,

nachfolgend das geänderte Makro, das hoffentlich funktionieren sollte:

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
'   Dim Zeile As Long
    
    'Überprüfe, ob Target (=geänderte Zelle) tatsächlich in N5 liegt:
[COLOR="#0000FF"]    If Intersect(Target, Range("N5")) Is Nothing Then Exit Sub[/COLOR]
    
    On Error GoTo Err_WsChange
    
    [COLOR="#FF0000"]Application.EnableEvents = False[/COLOR]
    
    Set rng = Me.Range("B5:B35").Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, Searchdirection:=xlNext)
    If rng Is Nothing Then
       MsgBox "Fehler"
    Else
       rng.Offset(0, 6).Value = Date
       'MsgBox "Zeile: " & rng.Row & "; Adresse: " & rng.Address
    End If
    
Ende_WsChange:
    [COLOR="#FF0000"]Application.EnableEvents = True[/COLOR]
    Exit Sub
    
Err_WsChange:
    Resume Ende_WsChange
    
End Sub

Des Rätsels Lösung, was den auftretenden Laufzeitfehler betrifft, sind die beiden rot gefärbten Zeilen zusammen mit der blauen Zeile.

Mit der ersten Zeile (Application.EnableEvents = False) wird die Ereignisbehandlung in Excel ausgeschaltet. Das Problem dahinter ist etwas heimtückisch.
Damit das Makro "Worksheet_Change(Target as Range)" gestartet wird, muss es im Arbeitsblatt eine Zelle (=Target) geben, in der sich der Zellwert geändert hat. Das Makro wird ausgeführt und wenn alles gut geht, kommt es an die Stelle (rng.Offset(0,6).Value=Date). Diese Anweisung bedeutet aber, dass sich im Arbeitsblatt ein Zellinhalt ändert. Und wie du schon ahnen wirst, wird dadurch dieses Makro schon wieder gestartet, obwohl es mit der Abarbeitung der ersten Änderung noch nicht fertig ist.
Es entsteht etwas, was die Programmierer einen "circulus vitiosus" (Zirkelschluss, Teufelskreis) nennen - das Programm beißt sich in den eigenen Schwanz und lässt dabei nicht locker (--> Programmabsturz).
Damit das nicht passiert, muss man zuerst die Excel-Ereignisbehandlung abschalten, die Programmaktivitäten ausführen und zum Schluss die Excel-Ereignisbehandlung sicher wieder einschalten. Tritt nämlich während des ganzen Ablaufes ein Fehler auf, darf das Programm nicht sofort abbrechen, sondern muss sicherstellen, dass die Event-Behandlung wieder aktiv gestellt wird (deshalb das Getue mit "On Error ...", etc.)

 

Hallo Anton

Danke für Deine Hilfe


Bin jetzt erst dazu gekommen es zu testen. Soweit klappt auch alles. Habe aber noch etwas geändert.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rng1 As Range
   Dim bln As Boolean
   For Each rng1 In Target.Cells
      If rng1.Value <> "" Then bln = True
   Next rng1
   If bln = False Then
      Beep
      MsgBox "Es wurde gelöscht!"
   Else
      
      '***** Ab hier Antons Code mit einer Ändrung von mir
      
              Dim rng As Range
'   Dim Zeile As Long
    
    'Überprüfe, ob Target (=geänderte Zelle) tatsächlich in N5 liegt:
    If Intersect(Target, Range("Q5")) Is Nothing Then Exit Sub
    
    On Error GoTo Err_WsChange
    
    Application.EnableEvents = False
    
    Set rng = Me.Range("C5:C350000").Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, Searchdirection:=xlNext)
    If rng Is Nothing Then
       MsgBox "Fehler"
    Else
       If rng.Offset(, 13) = "fällig" Then rng.Offset(, 8) = Date   'Änderung   geändert von rng.Offset(0, 6).Value = Date
       'MsgBox "Zeile: " & rng.Row & "; Adresse: " & rng.Address
       End If
        
Ende_WsChange:
    Application.EnableEvents = True
    Exit Sub
    
Err_WsChange:
    Resume Ende_WsChange
    
    '***** Bis hier mein Code
    
    
   End If
   
   'Worksheets("Übersicht").Range("Q5").Select
   'Worksheets("Übersicht").Range("Q5").Clear
   
End Sub

Was mir jetzt nour noch fehlt ist das ich immer in der Zelle Q5 bleibe und nach durch lauf des Codes die Zelle Q5 gelerrt wird. Das bekomme ich einfach nicht hin bekomme immer Laufzeitfehler und Automatisierungsfehler.


Gruß Michael

 

Hallo Michael,

der folgende Makrocode ist eine Modifikation deines Codes. Er setzt voraus, dass er sich im Codemodul des Arbeitsblattes "Übersicht" befindet, wobei er ausschließlich auf Zellwertänderungen (mittels Tastatur oder Maus) in diesem Arbeitsblatt reagiert. Ich habe dir überall zu/vor jeder VBA-Anweisung eine Kommentarzeile eingefügt, um die Verständlichkeit des Codes zu verbessern.

Die automatische Variable "Me" (blau gekennzeichnet) stellt dabei dasjenige Objekt dar, in dessen Codemodul sich der VBA-Code befindet (in diesem Fall das Arbeitsblatt "Übersicht").
Die erste Zeile ("Option Explicit") erzwingt, dass jede enthaltene Variable zuvor deklariert sein muss (mit DIM, PRIVATE, PUBLIC, etc). Diese erste Zeile sollte in jedem Codemodul vorhanden sein - sie kann viel Ärger beim Programmieren ersparen (oder zumindest reduzieren)!!

Code:

Option Explicit

'Target: ist die Zelle im Arbeitsblatt "Übersicht", in der die Wertänderung sich ereignet hat
Private Sub Worksheet_Change(ByVal Target As Range)
      
    Dim ErrAb As Byte
    
    'Überprüfe, ob Target (=Zelle mit geändertem Wert) tatsächlich in Q5 liegt: Falls nicht, verlasse die SUB!
    If Intersect(Target, [B][COLOR="#0000CD"]Me[/COLOR][/B].Range("Q5")) Is Nothing Then Exit Sub
    
    'Falls im Folgenden ein Fehler/Ausnahme auftritt, springe zur Marke "Err_WsChange"
    On Error GoTo Err_WsChange
    
    'Excels Ereignisverwaltung abschalten
    Application.EnableEvents = False: ErrAb = 1
    
    'Im Zellbereich C5:C350000 wird nach dem Wert aus Target (=Wert in Zelle Q5) gesucht:
    With [B][COLOR="#0000CD"]Me[/COLOR][/B].Range("C5:C350000").Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, Searchdirection:=xlNext)
       'Es wurde der Target-Wert aus Q5 gefunden:
       '     Falls in dieser Zeile in Spalte "P" der Wert "fällig" enthalten ist,
       '     dann speichere in dieser Zeile in Spalte "K" das heutige Datum.
       'Es wurde der Target-Wert aus Q5 NICHT gefunden:
       '     Es tritt, wenn die .Offset-Methode der nächsten Zeile aufgerufen wird,
       '     der Error 91 auf --> Programm springt zur Marke "Err_WsChange".
       If .Offset(, 13) = "fällig" Then .Offset(, 8) = Date
       ErrAb = 2
    End With
        
Ende_WsChange:
    ErrAb = 3
    'Abschlussarbeiten (sowohl bei ordnungsgemäßer als auch nach fehlerhafter Programmausführung):
    '(--> Dabei wird vorausgesetzt, dass sich dieses Arbeitsblatt-Codemodul im Codemodul des Arbeitsblattes "Übersicht" befindet)
    With Target
      'In Target (=Zelle Q5) alles löschen (bzw. Inhalte löschen)
      .ClearContents  'bzw.  .Clear
      'Zelle Target (=Zelle Q5) auswählen
      .Select
    End With
    
    'Excels Ereignisverwaltung wieder aktivieren
    Application.EnableEvents = True: ErrAb = 4
    
    'Die SUB wird hier endgültig verlassen.
    Exit Sub
    
Err_WsChange:
    'Da die Programmausführung hieher gelangte, muss vorher ein Fehler aufgetreten sein:
    If Err.Number = 91 And ErrAb = 1 Then
       'Spezielle Message, falls der Wert aus Q5 NICHT gefunden wurde:
       MsgBox Prompt:="Wert '" & Target.Value & "' aus " & Target.Address, _
              Buttons:=vbExclamation, Title:="Erfolglose Suche"
    Else
      'Allgemeine Fehler-Message:
      MsgBox Prompt:="Err " & Err.Number & " (" & Err.Description & ")" & vbNewLine & "ErrAb=" & ErrAb, _
             Buttons:=vbCritical, Title:="Unbehandelter Fehler"
    End If
    'Setze Fehlermodus zurück und setze Programmausführung bei der Marke "Ende_WsChange" fort
    Resume Ende_WsChange
    
'Formelles Ende der SUB:
End Sub

 

Hallo Anton


vielen herzlichen Dank es klappt super und ohne Fehler und Abstürze.

Grüße Michael