mehere Mails an Empfängern

Dim olApp As Object
Dim olMailItm As Object
Dim i As Integer
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
lz = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lz
If Cells(i, 2).Value > 0 Then
Cells(i, 1).Select
With olMailItm
.To = Cells(i, 2).Value
.Subject = "Jahresüberprüfung " & Cells(i, 1).Value
.Body = "Hallo," & Chr(13) & Chr(13) & "Test Text" & Chr(13) & Cells(i, 1).Value
.ReadReceiptRequested = True
.Attachments.Add "C:\Dokumente\\" & Cells(i, 2).Value & ".txt"
.Send
End With
End If
Next i
Set olMailItm = Nothing
Set olApp = Nothing