Vložení emailových adres do makra z buněk

[Snekment]

Dobrý den, mám zase jeden problem:

mám toto makro :
Sub odeslat_mejlikem()
'
' odeslat_mejlikem Makro
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Rozpis služeb"
.Body = ""
.Attachments.Add ActiveWorkbook.FullName
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Funguje skvělě jen bych potřeboval ,aby do řádku ".to" se sami doplnily adresy z otevřeného list tzn. v buňkách W70:W103 mám zapsané emailové adresy na které chci, aby tento sešit odešel. Dobré by bylo ,kdyby případné nevyplněné buňky(emailovou adresou) vynechal. Děkuji Šnek

[Azuzula]

Ahoj,
použij cyklus For Each, otestuj buňku na přítomnost adresy resp. znak "@" a odešli. Jestli nebudeš vědět jak, tak mrkni do spojleru.

Abbc3 Spoiler Show

Kód: Vybrat vše

Sub odeslat_mejlikem()
'
' odeslat_mejlikem Makro
Dim oblast As Variant
Dim cell As Variant
Dim OutApp As Object
Dim OutMail As Object

oblast = Range("W70:W103")

For Each cell In oblast 'projde každou buňku v oblasti
    If InStr(1, cell, "@", vbTextCompare) > 0 Then 'test na přítomnost "@" v textu buňky
        'odeslání mailu
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
        .to = cell
        .CC = ""
        .BCC = ""
        .Subject = "Rozpis služeb"
        .Body = ""
        .Attachments.Add ActiveWorkbook.FullName
        .Send 'or use .Display
        End With
        On Error GoTo 0
        
        Set OutMail = Nothing
        Set OutApp = Nothing
    End If
Next
End Sub

[Snekment]

Děkuji moc funguje to skvělě . Diky Snek