Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Daten")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = cell.Offset(-1, 4).Value
.Body = cell.Offset(0, 4).Value & " " & cell.Offset(0, -1).Value & "," & Chr(13) & cell.Offset(1, 4).Value & Chr(13) & cell.Offset(2, 4).Value & Chr(13) & cell.Offset(3, 4).Value & Chr(13) & cell.Offset(4, 4).Value & Chr(13) & cell.Offset(5, 4).Value & Chr(13) & cell.Offset(6, 4).Value & Chr(13) & cell.Offset(7, 4).Value & Chr(13) & cell.Offset(8, 4).Value & Chr(13) & cell.Offset(9, 4).Value & Chr(13) & cell.Offset(10, 4).Value & Chr(13) & cell.Offset(11, 4).Value & Chr(13) & cell.Offset(12, 4).Value & Chr(13)
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub