VBA E-mail küldése soronként

VBA E-mail küldése soronként
2021-02-03T19:54:49+01:00
2021-02-04T10:07:14+01:00
2022-12-06T17:30:39+01:00
Edina Nagy
Sziasztok, 
egy kis segítséget szeretnék kérni. Szerettem volna létrehozni egy olyan makrót ami email-eket küld ki soronként. A makró nagy részét meg is alkottam, de elakadtam annál a résznél, hogy soronként, a sorokhoz rendelt email címekre egyesével küldje ki a táblázat végéig.
Esetleg, ha tudnátok segíteni, nagyon hálás lennék. 
Előre is nagyon köszönöm,

Idáig jutottam : 

Sub Feladat_kikuldese()
Dim Outlookprogi As Object
Dim Email As Object
 
Set Outlookprogi = CreateObject("Outlook.Application")
Set Email = Outlookprogi.CreateItem(0)
 
On Error Resume Next
 
If Sheets("utolso_futas").Cells(1, 1) = Date Then
    If vbYes = MsgBox("Ma már futott, menjen?", vbYesNo) Then
        futhat = True
    Else
        futhat = False
    End If
Else
    futhat = True
End If
If futhat Then
   
Do 
 
Range("A1:G100").Font.Name = "Calibri"
Range("A1:G100").Font.Size = 11
 
ThisWorkbook.Worksheets("lista").Cells(2, 14) = Now
 
 
ThisWorkbook.Worksheets("lista").Cells(2, 1) = ThisWorkbook.Worksheets("Munka1").Cells(11, 2)
ThisWorkbook.Worksheets("lista").Cells(2, 2) = ThisWorkbook.Worksheets("Munka1").Cells(3, 2)
ThisWorkbook.Worksheets("lista").Cells(2, 3) = ThisWorkbook.Worksheets("Munka1").Cells(10, 2)
ThisWorkbook.Worksheets("lista").Cells(2, 4) = ThisWorkbook.Worksheets("Munka1").Cells(8, 2)
ThisWorkbook.Worksheets("lista").Cells(2, 5) = ThisWorkbook.Worksheets("Munka1").Cells(9, 2)
ThisWorkbook.Worksheets("lista").Cells(2, 6) = ThisWorkbook.Worksheets("Munka1").Cells(12, 2)
 
 
 
With Email
    .To = Worksheets("Munka1").Cells(2, 2).Value
    .CC = Worksheets("Munka1").Cells(2, 3).Value
    .Subject = Worksheets("Munka1").Cells(2, 4).Value
    .Body = Worksheets("Munka1").Cells(2, 5).Value & vbNewLine & vbNewLine & _
Worksheets("Munka1").Cells(2, 6) & vbNewLine & _
Worksheets("Munka1").Cells(2, 7) & vbNewLine & _
Worksheets("Munka1").Cells(2, 8) & Worksheets("Munka1").Cells(2, 9) & vbNewLine & _
vbNewLine & vbNewLine & _
Worksheets("Munka1").Cells(2, 10) & Worksheets("Munka1").Cells(2, 11) & vbNewLine & _
Worksheets("Munka1").Cells(2, 12) & vbNewLine & _
vbNewLine & vbNewLine & _
Worksheets("Munka1").Cells(2, 13)
    .Send
If Err.Number = 0 Then
                Sheets("utolso_futas").Cells(1, 1) = Date
            Else
                MsgBox Err.Description, vbOKOnly, "Hiba az elküldéskor"
            End If
        End With
         
        Set Email = Nothing
        Set Outlookprogi = Nothing
    End If
End If
End Sub
Mutasd a teljes hozzászólást!

Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd