ich dreh nochmal durch

ChrisStangl

Mitglied
Hi,

ich hab mir ein feines Excel-Makro geschrieben, daß aus einer Liste die Daten überprüft und dann, wenn das Datum näher an einem festgegebenen Wert liegt, eine Mail an den Betreffenden sendet.
Vorgaben sind:

Es soll, wenn eine Person mehrfach vorkommt, nur eine Mail an denjenigen versandt werden.

Die Mailadressen sollen nach dem Namen aus einem 2 Arbeitsblatt ausgelesen werden.

Mein Code sieht so aus:

Private Sub CommandButton1_Click()
Dim Ordner_incl_Name As String, Ordnername As String, Pfad As String, Reihe As Byte, zelle As String, x As String, y As Long, strDir, i, w!, w0%, w1!, z0%, z!, z1!, c!, c0%, c1!, d!, d0%, d1!, ol, mail As Object

Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(0)
y = 18
x = ActiveCell.Row
aktuell = Cells(3, 9)
Adresse = Cells(x, 3)
aktuell1 = Cells(4, 9)
aktuell2 = Cells(5, 9)

d0 = 2
c0 = 2
w0 = 2
z0 = 2
i = 1
'Auf jedem Blatt suchen

ausmailkopieren

Columns("D:D").Select
Selection.Copy
Columns("J:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Ersetzen

For Each Blatt In ActiveWorkbook.Sheets
'Soll nur auf den beiden Blättern gesucht werden, Hochkomma entfernen.
'If Blatt.Name = "Dienstlich" Or Blatt.Name = "Privat" Then
z = z0
z1 = z
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'Blatt auswählen
Sheets("Tabelle1").Select
'Solange auf dem Blatt suchen, wie in Spalte 5 was steht
Do Until Cells(z, 2).Value = "" And Cells((z + 1), 2).Value = "" And Cells((z + 2), 2).Value = "" And Cells((z + 3), 2).Value = ""
'Meldung in Statusleiste
Application.StatusBar = "Überprüft wird: " & Cells(z, 2).Value
'Bei Fehler weitere Schritte überspringen
On Error Resume Next
'Wenn Tag und Monat der Zelle in Spalte 6 = Heute sind
If (Cells(z, 2).Value) <= aktuell And (Cells(z, 6).Value) <> "x" And (Cells(z, 10).Value) <> "x" Then
Set mail = ol.CreateItem(0)
mail.Subject = Cells(z, 1) & " " & aktuell
mail.To = Cells(z, 3)
'mit body wird nur noch im txt-Format versandt!
mail.body = "Testmail Aktuell 1 Monat"
'mail anzeigen
mail.send
' mit dem folgenden Befehl kann direkt gesendet werden:
'mail.send
Cells(z, 6).Select
ActiveCell.FormulaR1C1 = "x"

Columns("J:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Replace What:=Cells(z, 3).Value, Replacement:="x", _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False

Do Until Cells(w, 2).Value = "" And Cells((w + 1), 2).Value = "" And Cells((w + 2), 2).Value = "" And Cells((w + 3), 2).Value = ""
'Meldung in Statusleiste
Application.StatusBar = "Überprüft wird: " & Cells(w, 3).Value
'Bei Fehler weitere Schritte überspringen
On Error Resume Next
If (Cells(w, 10).Value) = "x" And (Cells(w, 2).Value) <= aktuell Then
Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
:=True).Activate
ActiveCell.Select
Selection.Copy
Cells(w, 6).Select
ActiveSheet.Paste
w = w + 1
Else
w = w + 1
End If
Loop
z = z + 1
Else
z = z + 1
End If
Loop
Next
Application.ScreenUpdating = True

Columns("J:J").Select
Selection.Clear


Columns("C:C").Select
Selection.Copy
Columns("J:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False

For Each Blatt In ActiveWorkbook.Sheets
'Soll nur auf den beiden Blättern gesucht werden, Hochkomma entfernen.
'If Blatt.Name = "Dienstlich" Or Blatt.Name = "Privat" Then
z = z0
z1 = z
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'Blatt auswählen
Sheets("Tabelle1").Select
'Solange auf dem Blatt suchen, wie in Spalte 5 was steht
Do Until Cells(z, 2).Value = "" And Cells((z + 1), 2).Value = "" And Cells((z + 2), 2).Value = "" And Cells((z + 3), 2).Value = ""
'Meldung in Statusleiste
Application.StatusBar = "Überprüft wird: " & Cells(z, 2).Value
'Bei Fehler weitere Schritte überspringen
On Error Resume Next
'Wenn Tag und Monat der Zelle in Spalte 6 = Heute sind
If (Cells(z, 2).Value) <= aktuell1 And (Cells(z, 7).Value) <> "x" And (Cells(z, 10).Value) <> "x" Then
Set mail = ol.CreateItem(0)
mail.Subject = Cells(z, 1) & " " & aktuell
mail.To = Cells(z, 3)
'mit body wird nur noch im txt-Format versandt!
mail.body = "Testmail Aktuell 18 Tage"
'Mail anzeigen
mail.send
' mit dem folgenden Befehl kann direkt gesendet werden:
'mail.send
Cells(z, 7).Select
ActiveCell.FormulaR1C1 = "x"

Columns("J:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Replace What:=Cells(z, 3).Value, Replacement:="x", _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False

Do Until Cells(c, 3).Value = "" And Cells((c + 1), 3).Value = "" And Cells((c + 2), 3).Value = "" And Cells((c + 3), 3).Value = ""
'Meldung in Statusleiste
Application.StatusBar = "Überprüft wird: " & Cells(w, 3).Value
'Bei Fehler weitere Schritte überspringen
On Error Resume Next
If (Cells(c, 10).Value) = "x" And (Cells(c, 2).Value) <= aktuell1 Then
Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
:=False).Activate
ActiveCell.Select
Selection.Copy
Cells(c, 7).Select
ActiveSheet.Paste
c = c + 1
Else
c = c + 1
End If
Loop
z = z + 1
Else
z = z + 1
End If
Loop
Next
Application.ScreenUpdating = True

Columns("J:J").Select
Selection.Clear

Columns("C:C").Select
Selection.Copy
Columns("J:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False


For Each Blatt In ActiveWorkbook.Sheets
'Soll nur auf den beiden Blättern gesucht werden, Hochkomma entfernen.
'If Blatt.Name = "Dienstlich" Or Blatt.Name = "Privat" Then
z = z0
z1 = z
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'Blatt auswählen
Sheets("Tabelle1").Select
'Solange auf dem Blatt suchen, wie in Spalte 5 was steht
Do While Cells(z, 2).Value <> ""
'Meldung in Statusleiste
Application.StatusBar = "Überprüft wird: " & Cells(z, 2).Value
'Bei Fehler weitere Schritte überspringen
On Error Resume Next
'Wenn Tag und Monat der Zelle in Spalte 6 = Heute sind
If (Cells(z, 2).Value) < aktuell2 And (Cells(z, 8).Value) <> "x" And (Cells(z, 10).Value) <> "x" Then
Set mail = ol.CreateItem(0)
mail.Subject = Cells(z, 1) & " " & aktuell
mail.To = Cells(z, 3)
'mit body wird nur noch im txt-Format versandt!
mail.body = "Testmail Aktuell 5 Tage"
'Mail anzeigen
mail.send
' mit dem folgenden Befehl kann direkt gesendet werden:
'mail.send
Cells(d, 8).Select
ActiveCell.FormulaR1C1 = "x"

Columns("J:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Replace What:=Cells(z, 3).Value, Replacement:="x", _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False

Do While Cells(d, 3).Value <> ""
'Meldung in Statusleiste
Application.StatusBar = "Überprüft wird: " & Cells(w, 3).Value
'Bei Fehler weitere Schritte überspringen
On Error Resume Next
If (Cells(d, 10).Value) = "x" And (Cells(d, 2).Value) < aktuell2 Then
Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
:=False).Activate
ActiveCell.Select
Selection.Copy
Cells(d, 8).Select
ActiveSheet.Paste
d = d + 1
Else
d = d + 1
End If
Loop
z = z + 1
Else
z = z + 1
End If
Loop
Next
Application.ScreenUpdating = True

Columns("J:J").Select
Selection.Clear

Cells(ActiveCell.Row, 2).Select


End Sub

Ich bin für jede Hilfe dankbar. Bin auch nicht böse, wenn jemand nen schöneren, schnelleren Code hat :)

Chris
 
ich hab mir ein feines Excel-Makro geschrieben, daß aus einer Liste die Daten überprüft und dann, wenn das Datum näher an einem festgegebenen Wert liegt, eine Mail an den Betreffenden sendet.
Vorgaben sind:

Es soll, wenn eine Person mehrfach vorkommt, nur eine Mail an denjenigen versandt werden.

Die Mailadressen sollen nach dem Namen aus einem 2 Arbeitsblatt ausgelesen werden.
Sehr schön, aber aus welchem Grund drehst du dabei durch?
 
Weil das Makro zwar mit dem 1 Namen genau das macht, was es soll, aber später übergeht es Namen, schickt Mails 2x usw. Und ich durchblick langsam nimmer, warum. :-(
 
Zurück