• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excelde herbir sayfayı mail gönderme

H

Hakngnc

Katılım
21 Ağustos 2015
Mesajlar
76
Excel Vers. ve Dili
İşte Office 13-Türkçe
Evde Office 10-Türkçe
Arkadaşlar merhaba,
Excelde yaklaşık 800 sayfalık bir verim var herbir sayfa ayrı bir şubeyi temsil ediyor.
Herbir şubeye mail atmam gerekiyor. (Excel dosyamdaki 2. sayfa ilgili şubeye,3.sayfa ilgili şubeye gibi). İlk excel sayfamda A Sutununda ilgili şubelerin mail adresleri var.

Yardımlarınızı rica ederim.

Teşekkürler.
 
Dosyanızın küçük bir örneğini ekler misiniz?
 
örnek

İlgili örnek dosya ektedir.
Teşekkürler şimdiden. Herbir sayfayı ayrı olarak mail atmak istiyorum.
 

Ekli dosyalar

Deneyin.

Kod: 
Sub Mail_Gonder()
    Dim S1 As Worksheet, rng As Range
    Dim Son As Long, Sayfa As Worksheet, Veri As Range
    Dim OutApp As Object, OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Set S1 = Sheets("atılacak mail adresleri")
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row

    For Each Veri In S1.Range("A1:A" & Son)
        Set rng = Nothing
        On Error Resume Next
        Set Sayfa = Sheets(Veri.Text)
        Set rng = Sayfa.Range("A1:E9")
        On Error GoTo 0
    
        On Error Resume Next
        With OutMail
            .Display
            .To = TR_Karakter_Sil(LCase(Replace(Sayfa.Range("B3").Value, " ", ".") & "@hotmail.com"))
            .CC = ""
            .BCC = ""
            .Subject = "Anket Sonuçları"
            .HTMLBody = RangetoHTML(rng)
            [COLOR="Red"].Send[/COLOR]
        End With
        On Error GoTo 0
    Next

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function TR_Karakter_Sil(Adres As String)
    Eski_Karakter = Array("ı", "ç", "ğ", "ö", "ş", "ü")
    Yeni_Karakter = Array("i", "c", "g", "o", "s", "u")
    For X = 0 To UBound(Eski_Karakter)
        If TR_Karakter_Sil = "" Then
            TR_Karakter_Sil = Replace(Adres, Eski_Karakter(X), Yeni_Karakter(X))
        Else
            TR_Karakter_Sil = Replace(TR_Karakter_Sil, Eski_Karakter(X), Yeni_Karakter(X))
        End If
    Next
End Function
 
Çok teşekkür ederim.İş yerinde ana datayla deneyeceğim.Takıldığım bir yer olursa tekrar sorabilir miyim? Üstad vakit ayırdığın için tekrardan teşekkür ederim.
 
Deneyin. Sorun olursa yardımcı olurum.
 
Gönderdiğiniz kodu çalıştırdım boş outlook sayfası açıldı.Sadece konu kısmı dolu ne bir ek nede bir kullanıcı gözüküyor tek tek sayfaları göndermek için sayfayı bir ek olarak mı gönderecek bu kodlama?
 
Kod içindeki aşağıdaki satır ilgili hücre aralığını mailin gövde kısmına ekleyerek mail gönderir.

Kod: 
Set rng = Sayfa.Range("A1:E9")

Dilerseniz excel sayfası olarak ta gönderilebilir.

Kodda küçük bir düzeltme yaptım. Son halini kullanınız. (.Send satırı eklendi.)
 
Nerede son hali Korhan bey küçük düzeltme yaptım demişsiniz, son halini bulamadım.Bide bu kodu gövde derken neresini kastettiniz anlayamadım.
.Send satırlı halini bulamadım.
Bu en son gönderdiğiniz hücre aralığı a1:e9 arası rng sheetleri mi temsil ediyor anlayamadım tam olarak kusura bakmayın cahilim biraz
 
Son hali 4 nolu mesajımdadır.

4 nolu mesajımda ".Send" satırını kırmızı renkle belirttim.

Sizin eklediğiniz dosyada mail atılacak sayfalarda A1:E9 hücre aralığında veriler olduğu için koda bu alanı tanımladım. Sizin asıl dosyanızda hücre aralığı neyse ona göre değiştirebilirsiniz.
 
Teşekkür ederim Korhan bey asıl dataya uyarlayamadım ama gönderdiğim örnek data için çalışıyor.Asıl datada sadece a1:n17 yaptım orasını kapsıyor diye fakat mailin gövde kısmına gelmiyor ilgili yer ve kime kısmıda boş duruyor.Asıl datada B3'ün değeri (Gönderilecek kişinin adı soyadı) düşeyara fonksiyonlu olduğu için olabilir mi?
 
Küçük bir sorum daha olacak."Atılacak mail adresleri" sheetine ihtiyacımız yok sanırım. Siz zaten ad soyad arasına nokta koyup @hotmail demişsiniz. Yanlış mı düşünüyorum? "atılacak mail adresleri" sayfasındaki kurduğunuz for next döngüsü ne için acaba o kısmı da anlayamadım.Kodu kafamda tam kurgulayabilirsem kendi ana datama uyarlayacağım. Kusura bakmayın çok soru sordum.Teşekkürler yardımınız için.
 
"atılacak mail adresleri" sayfasındaki "A" sütunundaki sayfa adlarına göre mail atma işlemi yapmaktadır. Dilerseniz silinebilir fakat döngüyü değiştirmek gerekir. Yoksa kod bu haliyle çalışmaz.
 
Şimdi oturdu tamamiyle çok teşekkür ederim yardımlarınız için çalıştırdım :)
 
excel sayfa bazında mail atma

forumda daha önceden bulduğum fakat kendi excelime uyarlama yapamadığım bir sorundur bu excel dosyamın içinde sayfalar var ve bu sayfaların her biri farklı bir mail adresine gitmesi gerekmekte yardımcı olursanız sevinirim
 
Merhaba,

Dosyanızın küçük bir örneğini ekleyin ve nasıl mail atmak istediğinizi açıklayın.
 
Dosyaları İşaretleyerek Outlok ile E-Mail Göndermek.

Korhan Bey Merhaba, Mail gönderme konusunda çok fazla başlık olduğundan aynı konuyla ilgili yeni bir başlık açmadım. Bir hayli aynı konulara baktım ama sorunumu doğru bir şekilde çözemedim. Yardımcı olursanız minnettar olurum.

Ekteki dosyada birçok pdf dosyam var. Onları makro ile excele alıyorum. Ama işaretleyerek bazılarını şu e-mail'e bazılarını bu e-mail' işaretleyerek Outluk ile e-mail göndermek istiyorum.

Şimdiden teşekkür eder saygılar sunarım.
 

Ekli dosyalar

Filose' Alıntı:
Korhan Bey Merhaba, Mail gönderme konusunda çok fazla başlık olduğundan aynı konuyla ilgili yeni bir başlık açmadım. Bir hayli aynı konulara baktım ama sorunumu doğru bir şekilde çözemedim. Yardımcı olursanız minnettar olurum.

Ekteki dosyada birçok pdf dosyam var. Onları makro ile excele alıyorum. Ama işaretleyerek bazılarını şu e-mail'e bazılarını bu e-mail' işaretleyerek Outluk ile e-mail göndermek istiyorum.

Şimdiden teşekkür eder saygılar sunarım.
Genişletmek için tıkla ...
. . .

Dosyanız ektedir...

Dosya yolunu kendi bilgisayarınıza göre değiştirin. (PDF lerin bulunduğu klasör yolu)

X işareti olan dosyaları, X işareti olan mail adresine gönderir.

do.php


Kod: 
Sub KOD()
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Dim S1 As Worksheet: Set S1 = Sheets("Sayfa1")
    yol = "[COLOR="DarkRed"]C:\Users\Hüseyin\Desktop\Yeni klasör (2)\[/COLOR]"
    
    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
    
    For s = 1 To S1.Cells(Rows.Count, "E").End(3).Row
        If UCase(S1.Cells(s, "E")) = "X" Then
            kime = S1.Cells(s, "D")
            Exit For
        End If
    Next s
    
    Dim xlOutlook   As Object
    Dim xlMail      As Object
    Set xlOutlook = CreateObject("Outlook.Application")
    Set xlMail = xlOutlook.CreateItem(0)
    
    With xlMail
        .To = kime
        .Subject = "Konu"
        .Body = ""
        For e = 1 To n
            .Attachments.Add dizi(e)
        Next e
        .Save
        .Display
       [COLOR="Green"] '.Send[/COLOR]
    End With
    
    Set xlMail = Nothing
    Set xlOutlook = Nothing
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

. . .
 

Ekli dosyalar

Hüseyin Bey kardeşim çok teşekkür ederim.
Yazdığınız kodlar tam istediğim gibi oldu. Ellerinize sağlık.

Hoşçakalın...
 
Bilgi..

saygılar herkese..
ekteki tabloda her personelin yapmış olduğu masraf satırlarını içeren sekmeleri ilgili personellerin anasayfadaki mail adreslerine "sekmeleri ek olarak" ekleyerek göndermek istemekteyim..forumda text olarak aktarmakta olduğundan yardımlarınıza başvurmak istedim..
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst