Thema Datum  Von Nutzer Rating
Antwort
24.05.2023 14:36:37 xlanthir
NotSolved
24.05.2023 15:39:07 Mase
NotSolved
24.05.2023 18:21:54 Gast70908
NotSolved
Blau Protokollierung funktioniert nicht
25.05.2023 14:06:08 xlanthir
NotSolved
25.05.2023 15:05:22 Gast36136
NotSolved

Ansicht des Beitrags:
Von:
xlanthir
Datum:
25.05.2023 14:06:08
Views:
238
Rating: Antwort:
  Ja
Thema:
Protokollierung funktioniert nicht

Das jetzige Skript führt zwar die Protokollierung aus und zeigt keine Fehlermeldung mehr an, jedoch funktioniert die automatische Verschickung der Mail nicht. Würde jemanden der Fehler auffallen?


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ProtokollSheet As Worksheet
    Dim letzteZeile As Long
    Dim Benutzer As String
    Dim Aktion As String
    
    ' Überprüfen, ob die Änderungen in der Tabelle "Lager" stattfinden
    If Target.Worksheet.Name = "Lager" Then
        ' Definieren des Protokollblatts
        Set ProtokollSheet = ThisWorkbook.Sheets("Protokoll")
        
        ' Ermitteln der letzten Zeile im Protokollblatt
        letzteZeile = ProtokollSheet.Cells(ProtokollSheet.Rows.Count, 1).End(xlUp).Row + 1
        
        ' Benutzername erfassen
        Benutzer = Application.UserName
        
        ' Aktion erfassen
        If Target.Value = "" Then
            Aktion = "Gelöscht"
        Else
            Aktion = "Geändert: " & Target.Value
        End If
        
        ' Protokolldatum erfassen
        ProtokollSheet.Cells(letzteZeile, 1).Value = Benutzer
        
        ' Datum und Uhrzeit erfassen
        ProtokollSheet.Cells(letzteZeile, 2).Value = Now()
        
        ' Geänderte Zelle erfassen
        ProtokollSheet.Cells(letzteZeile, 3).Value = Target.Address
        
        ' Änderung erfassen
        ProtokollSheet.Cells(letzteZeile, 4).Value = Aktion
        
        ' Speichern der Arbeitsmappe
        ThisWorkbook.Save
    End If
    
    ' Bereich 1: E2:E9 - Bestand unter 20
    Dim BestandRange1 As Range
    Dim ProduktRange1 As Range
    Dim BestandCell1 As Range
    Dim ProduktCell1 As Range
    Dim BestandThreshold1 As Integer
    
    ' Bereich 2: E11:E51 - Bestand unter 1
    Dim BestandRange2 As Range
    Dim ProduktRange2 As Range
    Dim BestandCell2 As Range
    Dim ProduktCell2 As Range
    Dim BestandThreshold2 As Integer
    
    ' E-Mail Informationen
    Dim MailAdresse As String
    Dim Betreff As String
    Dim Nachricht As String
    
    ' Definieren Sie den Bereich 1: E2:E9 und C2:C9
    Set BestandRange1 = Range("E2:E9")
    Set ProduktRange1 = Range("C2:C9")
    BestandThreshold1 = 20 ' Schwellenwert für Bestand unter 20
    
    ' Definieren Sie den Bereich 2: E11:E51 und C11:C51
    Set BestandRange2 = Range("E11:E51")
    Set ProduktRange2 = Range("C11:C51")
    BestandThreshold2 = 1 ' Schwellenwert für Bestand unter 1
    
    ' E-Mail-Adresse des Empfängers
    MailAdresse = "E-Mail"
    
    ' Betreff für die E-Mail
    Betreff = "Bestandsbenachrichtigung"
    
    ' Überprüfen Sie nur die Änderungen in den Bestandsbereichen
    
    ' Bereich 1: E2:E9
    If Not Intersect(Target, BestandRange1) Is Nothing Then
        For Each BestandCell1 In Intersect(Target, BestandRange1)
            If BestandCell1.Value < BestandThreshold1 Then
                Set ProduktCell1 = ProduktRange1.Cells(BestandCell1.Row - ProduktRange1.Cells(1).Row + 1)
                Nachricht = "Der Bestand des Produkts " & ProduktCell1.Value & " beträgt " & BestandCell1.Value & "."
                SendEmail MailAdresse, Betreff, Nachricht
            End If
        Next BestandCell1
    End If
    
    ' Bereich 2: E11:E51
    If Not Intersect(Target, BestandRange2) Is Nothing Then
        For Each BestandCell2 In Intersect(Target, BestandRange2)
            If BestandCell2.Value < BestandThreshold2 Then
                Set ProduktCell2 = ProduktRange2.Cells(BestandCell2.Row - ProduktRange2.Cells(1).Row + 1)
                Nachricht = "Der Bestand des Produkts " & ProduktCell2.Value & " beträgt " & BestandCell2.Value & "."
                SendEmail MailAdresse, Betreff, Nachricht
            End If
        Next BestandCell2
    End If
End Sub

Sub SendEmail(ByVal MailAdresse As String, ByVal Betreff As String, ByVal Nachricht As String)
    Dim objOutlook As Object
    Dim objMail As Object
    
    ' Erstellen einer neuen E-Mail im Outlook
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    With objMail
        .To = MailAdresse
        .Subject = Betreff
        .Body = Nachricht
        .Send ' Versendet die E-Mail direkt
    End With
    
    ' Objekte freigeben
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
24.05.2023 14:36:37 xlanthir
NotSolved
24.05.2023 15:39:07 Mase
NotSolved
24.05.2023 18:21:54 Gast70908
NotSolved
Blau Protokollierung funktioniert nicht
25.05.2023 14:06:08 xlanthir
NotSolved
25.05.2023 15:05:22 Gast36136
NotSolved