İşaretlenen Dosyalara Toplu Mail Göndermede Değişillik

[Filose]

Herkese Merhaba,

Aslında konu açılacak bir başlık değil. Ama beceriksizliğim yüzünden ekte gönderdiğim makroda değişikliği yapamadım. Makro çalışıyor ve hata yok.

Yalnızca B sütununda işaretlenen dosyaları E Sütunundaki mail adreslerine toplu göndermek için;

If Cells(ActiveCell.Row + 1, 5) = "X" Then
kime2 = Cells(ActiveCell.Row + 1, 4)

Bu satırlarında yapacağım değişikliği bir türlü beceremedim. Dosyada daha ayrıntılı bilgi vardır. Herkese teşekkür eder ellerine sağlık diyorum.

 

[Ömer BARAN]

Merhaba.
Outlook kullanmadığım için deneme şansım yok ama mevcut KOD'u aşağıdaki şekilde değiştirerek dener misiniz?

Sub Mail_Gönder()
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim S1 As Worksheet: Set S1 = Sheets("Mail")
    yol = "C:\Users\Ahmet\Desktop\Posta\"
    
    Dim dizi()
    For i = 1 To S1.Cells(Rows.Count, "B").End(3).Row
        If UCase(S1.Cells(i, "B")) = "X" Then
            n = n + 1
            ReDim Preserve dizi(n)
            dizi(n) = yol & S1.Cells(i, "A")
        End If
    Next i
    
    Dim xlOutlook   As Object
    Dim xlMail      As Object
    Set xlOutlook = CreateObject("Outlook.Application")
    Set xlMail = xlOutlook.CreateItem(0)

For kim = 1 To [F65536].End(3).Row
    If Cells(kim, 5) = "" Then GoTo 10
    kime = Cells(kim, 4)
    
    With xlMail
        .To = kime
        .Subject = " === E-TEBLİGAT Bilgilendirme === "
        .Body = ""
        For e = 1 To n
            .Attachments.Add dizi(e)
        Next e
        .Save
        .Display
        '.Send
    End With
10: Next
    
    Set xlMail = Nothing
    Set xlOutlook = Nothing
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[Filose]

Merhaba Ömer Bey, öncelikle ilgi ve alakanıza çok teşekkür ederim. Kodu değiştirdim. B sütununda eğer 1 adet X işareti koyarsam 8 dosya maile ekliyor. 2 adet X işareti koyarsam 16 dosya maile ekliyor. Buradaki sorun kaç tane X işaret koyarsam maile o kadar eklesin.

Diğer sorun ise; E sütununda sadece en son X ile işaretlenen bir adet maile gönderiyor. Buradaki sorun ise; B sütununa ne kadar X işareti koyarsam sadece onlara mail göndersin.

Tekrar çok teşekkür ederim.

 

[Korhan Ayhan]

Örnek dosyanıza göre olması gereken senaryoyu açıklar mısınız?

 

[Filose]

Merhaba Korhan Bey,
Ekli dosyamda ayrıntılar vardır. İşin özü şu; bir klasörde email gönderilecek bir çok dosyam var. makro ile onları a sütununa alıyorum. B sütununda istediğim kadar dosyalara X ile işaretliyorum. E sütununda X ile işaretlediğim (Şirketin sadece 2 adet email adresine X işareti koyuyorum) email adreslerine gitmesi için şirkete çift tıklıyorum ve o şirketin 2 adet email adresine gidiyor. Buraya kadar hiç bir sorun yok.

Aynı makro ile (Mail_Gönder) farklı bir şey istiyorum. Şöyleki; B sütununda işaretlediğim dosyaları bu sefer E sütununda ne kadar X işareti koyarsam Mail Gönder Tuşu ile tümüne göndersin.

Kısaca; Her firmaya çift tıklayarak onların 2 adet emaillerine gönderebiliyorum. Ama, MAIL GÖNDER tuşu ile de E sütununda X işareti olan herkese göndersin.

Neden böyle; Bazen firmaların kendileri için olan dosyaları sadece kendilerine bazen de ortak olan dosyaları herkese (X ile işaretlediğim) göndermek istiyorum.

Teşekkür eder saygılar sunarım Korhan Bey

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz...

Sub Toplu_Mail_Gönder()
    Dim xlOutlook As Object
    Dim xlMail As Object
    Dim Dizi()
    
    Set xlOutlook = CreateObject("Outlook.Application")
    Set xlMail = xlOutlook.CreateItem(0)
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim S1 As Worksheet: Set S1 = Sheets("Mail")
    Yol = "C:\Users\Ahmet\Desktop\Posta\"
    
    For X = 1 To S1.Cells(S1.Rows.Count, "B").End(3).Row
        If UCase(S1.Cells(X, "B").Value) = "X" Then
            Say = Say + 1
            ReDim Preserve Dizi(Say)
            Dizi(Say) = Yol & S1.Cells(X, "A").Value
        End If
    Next
    
    For Y = 1 To S1.Cells(S1.Rows.Count, "E").End(3).Row
        If UCase(S1.Cells(Y, "E")) = "X" Then
            Kime = IIf(Kime = "", S1.Cells(Y, "D").Value, Kime & ";" & S1.Cells(Y, "D").Value)
        End If
    Next
    
    With xlMail
        .To = Kime
        .Subject = " === E-TEBLİGAT Bilgilendirme === "
        .Body = ""
        For Z = 1 To Say
            .Attachments.Add Dizi(Z)
        Next
        .Save
        .Display
        '.Send
    End With
    
    Set xlMail = Nothing
    Set xlOutlook = Nothing
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[Filose]

Korhan Bey Merhaba,

Çok teşekkür ederim tam istediğim gibi oldu. Ellerinize sağlık, hayırlı günler dilerim.