Hallo SnowWhite,
hier das geänderte Anlegen-Makro:
Sub Anlegen()
Dim Wiederholungen As Long
Dim wksL As Worksheet
Dim lngEinfZeile As Long
Set wksL = Worksheets("urliste")
Application.ScreenUpdating = False
For Wiederholungen = 1 To wksL.Cells(Rows.Count, 1).End(xlUp).Row
If wksL.Cells(Wiederholungen, 1) <> vbNullString Then
'Name des neu angelegten Tabellenblatts wird in versteckte Tabelle geschrieben
With Worksheets("Test")
'letzte beschriebene Zeile in Spalte A ermitteln und um 1 erhöhen für neue Einfügezeile
lngEinfZeile = .Cells(Rows.Count, 1).End(xlUp).Row + 1
'falls letzte Zeile 1 ist, dann prüfen, ob in A1 etwas steht
'falls Zelle A1 leer ist, dann 1. Einfügezeile auf 1 setzen
If lngEinfZeile = 2 And .Range("A1") = "" Then lngEinfZeile = 1
'Name des Tabellenblatts in verstecktes Blatt schreiben
.Cells(lngEinfZeile, 1) = wksL.Cells(Wiederholungen, 1).Value
End With
Worksheets("Leer").Copy After:=Sheets(Sheets.Count) 'Tabellenblatt "Leer" wird kopiert
With ActiveSheet
'Neues Blatt umbenennen
.Name = wksL.Cells(Wiederholungen, 1).Text 'Als TB Name des neu erstellten TB wird der Name aus der aktiven Zelle genommen von TB urliste.
.Range("O2:O50") = wksL.Cells(Wiederholungen, 2).Value
End With
'Einträge in Tabelle urliste löschen
With wksL
.Range(.Cells(Wiederholungen, 1), .Cells(Wiederholungen, 2)).ClearContents
End With
Else
Exit Sub
End If
Next
Set wksL = Nothing
Application.ScreenUpdating = True
End Sub
Das Makro Check-Mail habe ich jetzt so umgeschrieben, dass es auch ohne Fehler funktionieren sollte, wenn nur eine Tabelle angelegt ist. Gleichzeitig habe ich eine Prüfung eingebaut, die prüft, ob das Arbeitsblatt existiert:
Private Sub Check(ByVal Zeile As Long)
Dim Urgenz1 As String
Dim Urgenz2 As String
Urgenz1 = "x"
Urgenz2 = "x"
Dim i As Long
Dim t As Long
Dim b As Long
Dim lngLetzte As Long
Dim strTabelle As String
Dim wksTabellen As Worksheet
Set wksTabellen = ThisWorkbook.Worksheets("Test")
'Namen der neu angelegten Tabellenblätter aus versteckter Tabelle einlesen
'letzte beschriebene Zeile in Spalte A des versteckten Tabellenblatts ermitteln
lngLetzte = wksTabellen.Cells(Rows.Count, 1).End(xlUp).Row
'nun alle Zeilen dieses Blattes durchlaufen und die Namen der versteckten Tabellenblätter einlesen
For t = 1 To lngLetzte
'Namen in Variable einlesen
strTabelle = wksTabellen.Cells(t, 1).Value
'prüfen, ob Tabelle in Arbeitsmappe existiert
For b = 1 To ThisWorkbook.Worksheets.Count
If Worksheets(b).Name = strTabelle Then
With ThisWorkbook.Worksheets(strTabelle)
For i = Zeile + 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(i, 7).Value <> "" Then
If (CDate(.Cells(i, 7).Value) < DateTime.Date) And (.Cells(i, 13).Value = "x") Then ' Wenn Spalte "G" Datum = heutiges Datum & Spalte "M" auf "Leer" Dann
'MsgBox "Email schon geschickt", vbInformation, "Fertig" 'Message Box als Hilfe stellung
ElseIf .Cells(i, 7).Value <> "" And (CDate(.Cells(i, 7).Value) < DateTime.Date) And (CStr(.Cells(i, 13).Value) = vbNullString) Then 'Wenn Spalte "G" Datum = heutiges Datum & Spalte "M" auf "Leer" Dann
.Cells(i, 13).Value = Urgenz1 'Füge Urgenz1 in Spalte M
Call Send_Email(i, strTabelle) 'Aufruf Prozedur "Send_Email()"
End If
End If
If .Cells(i, 8).Value <> "" Then
If .Cells(i, 8).Value <> "" And (CDate(.Cells(i, 8).Value) < DateTime.Date) And (CStr(.Cells(i, 14).Value) = vbNullString) Then 'Wenn Spalte "H" Datum = heutiges Datum & Spalte "N" auf "Leer" Dann
.Cells(i, 14).Value = Urgenz2 'Füge Urgenz2 in Spalte N
Call Send_Erinnerung(i, strTabelle) 'Aufruf Prozedur "Send_Erinnerung"
End If
End If
Next i
End With
End If
Next b
Next t
' Call MsgBox("Fertig!", vbOKOnly)
End Sub
Getestet habe ich es jetzt nicht. Schau mal, ob alles funktioniert.
Gruß
M.O.
