Automatische Mail, dabei leere Zellen überspringen VBA
14.11.2023 20:32:44
Max
mir wurde hier im Forum vor längerer Zeit super geholfen, Vielen Dank nochmal dafür!
Jetzt habe ich ein weiteres Problem und komme nicht weiter.
Es sollen die Notizen aus Spalte 6 in meine Mail übernommen werden.
Für jeden Auftrag werden die Notizen nur in einer Zeile eingegeben.
Es soll also nur das Notizfeld übernommen werden, welches nicht leer ist.
Jetzt wird in meinem Code immer nur das oberste Notizfeld des jeweiligen Auftrags übernommen.
Es kann aber vorkommen, dass die Notizen nicht immer im der obersten Zeile des entsprechende Auftrags stehen.
Hat jemand dafür eine Lösung?
Meine Tabelle1 sieht wie folgt aus:
Spalten -> Spalte 1 :: Spalte 2 :: Spalte 3 :: Spalte 4 :: Spalte 5 :: Spalte 6 :: Spalte 7 ::
Zeile 1 -> Kalenderwoche :: Kunde :: Auftragsnummer :: Auftragsdatum :: Wareneingang :: Notiz :: letzte Erinnerungsmail verschickt am ::
Zeile 2 -> KW 5 :: Kunde A :: Auftrag A :: 1.1.2023 :: 20.1.2023 :: (leer) :: 8.1.2023 ::
Zeile 3 -> KW 5 :: Kunde A :: Auftrag A :: 1.1.2023 :: 20.1.2023 :: Testnotiz1 :: 8.1.2023 ::
Zeile 4 -> KW 4 :: Kunde B :: Auftrag B :: 1.2.2023 :: 23.2.2023 :: Testnotiz2 :: 10.2.2023 ::
In folgendem VBA-Code werden Mails in Outlook vorbereitet und können dann bei Bedarf verschickt werden.
Option Explicit
Public strTo As String, strCc As String, strSubj As String, strBody As String
Sub AutoSendWareneingangohneAuftrag()
Dim iZeile As Integer, iLR As Integer, dWo As Double, iZ1 As Integer
Dim AfDat As Date, WeDat As Date
iZ1 = 3 'erste Zeile mit Daten
With Sheets("Tabelle1")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte
For iZeile = iZ1 To iLR
If .Cells(iZeile, 2) > "" Then
AfDat = .Cells(iZeile, 4)
WeDat = .Cells(iZeile, 5)
'noch kein Auftrag und keine mail seit 7 Tagen
If AfDat = 0 And Date - AfDat > 7 Then
'noch keine mail oder letzte mail älter als 7 Tage
If .Cells(iZeile, 7) = "" Or Date - .Cells(iZeile, 7) > 7 Then
'Prüfen ob es sich um gleichen Kunden, gleiche Auftragsnummer handelt
'und bereits eine mail für HEUTE vorliegt
If WorksheetFunction.CountIfs(.Cells(iZ1, 2).Resize(iZeile - iZ1 + 1, 1), .Cells(iZeile, 2), _
.Cells(iZ1, 3).Resize(iZeile - iZ1 + 1, 1), .Cells(iZeile, 3), _
.Cells(iZ1, 7).Resize(iZeile - iZ1 + 1, 1), ">&date") = 1 Then
' Letzte mail eintragen in Spalte 7
.Cells(iZeile, 7) = Date
'Woche
dWo = Round((Date - AfDat) / 7, 1)
'Mail zusammenbauen
strTo = .Cells(iZeile, 2)
strCc = ""
strSubj = "Erinnerungsmail"
strBody = "Kunde: " & .Cells(iZeile, 2) & "
"
strBody = strBody & "Auftragsnummer: " & .Cells(iZeile, 3) & "
"
strBody = strBody & "Auftragsdatum: " & .Cells(iZeile, 4) & "
"
strBody = strBody & "Notizen: " & .Cells(iZeile, 7) & "
"
strBody = strBody & "Für Auftrag " & .Cells(iZeile, 3) & " ist Ware bei uns eingetroffen."
Call send_Email(strTo, strCc, strSubj, strBody)
Else
'Bei Bedarf keine mail bei Wiederholung, aber trotzdem Datum in Spalte 7 reinschreiben
.Cells(iZeile, 7) = Date
End If
End If
End If
End If
Next
End With
End Sub
Sub send_Email(strTo, strCc, strSubj, strBody)
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.Subject = strSubj
.To = strTo
.Cc = strCc
.htmlbody = strBody
.Display
End With
Set olApp = Nothing
End Sub