Excel Sayfasını Mail Olarak Gönderme

s4kinqz · 21 Şubat 2021

Merhaba Arkadaşlar,

Makro öğrenmeye yeni başladım. işime yarayabilecek bir dosya yapmaya çalışıyorum fakat bir yerde tıkandım. Site üzerinden de kontrol ettim fakat her denemem başarısız oldu.

Örnek dosyada ki gibi bir süz işlemi yaptım ve süzden sonra o tuşa atanacak olan mail adresine süzülen sayfanın gitmesini istiyorum.

Teşekkürler

Korhan Ayhan · 21 Şubat 2021

Kodun içine açıklamalar yazdım.

Uygun şekilde tanımlamalar yaparak kullanabilirsiniz.

C++:

Option Explicit

Sub Filtrelenmiş_Verileri_Mail_Gonder()
    Dim S1 As Worksheet, Uygulama As Object, Yeni_Mail As Object
    Dim Dosya_Adi As String, Mesaj As String
   
    Set S1 = Sheets("Sheet1")
   
    Dosya_Adi = ThisWorkbook.Path & "\Dosya_Adi.xlsx"

    With S1
        .Range("A1:C" & .Rows.Count).AutoFilter Field:=1, Criteria1:="satın alma"
        .Range("A1").CurrentRegion.Copy
    End With
   
    Workbooks.Add (1)
    ActiveSheet.Paste
    Columns.AutoFit
    Range("A1").Select
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Dosya_Adi, 51
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
   
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
   
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
   
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
   
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)
   
    Mesaj = "Merhaba," & "<br><br>" & "Mail gövdesinde görmek istediniz mesajı buraya yazınız." & "<br><br>" & _
            "İyi çalışmalar dileriz."
   
    Mesaj = "<p style='color:black;font-family:Arial;font-size:13.5'>" & Mesaj & "</font></p>"
   
    With Yeni_Mail
        .Display
        .To = "Göndermek istediğiniz mail adresini yazınız."
        .Cc = ""
        .Bcc = ""
        .Subject = "Mail konusunu buraya yazınız."
        .HTMLBody = Mesaj & .HTMLBody
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
   
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

s4kinqz · 22 Şubat 2021

Korhan Ayhan' Alıntı:

Kodun içine açıklamalar yazdım.

Uygun şekilde tanımlamalar yaparak kullanabilirsiniz.

C++:

Option Explicit

Sub Filtrelenmiş_Verileri_Mail_Gonder()
    Dim S1 As Worksheet, Uygulama As Object, Yeni_Mail As Object
    Dim Dosya_Adi As String, Mesaj As String
  
    Set S1 = Sheets("Sheet1")
  
    Dosya_Adi = ThisWorkbook.Path & "\Dosya_Adi.xlsx"

    With S1
        .Range("A1:C" & .Rows.Count).AutoFilter Field:=1, Criteria1:="satın alma"
        .Range("A1").CurrentRegion.Copy
    End With
  
    Workbooks.Add (1)
    ActiveSheet.Paste
    Columns.AutoFit
    Range("A1").Select
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Dosya_Adi, 51
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
  
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
  
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
  
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
  
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)
  
    Mesaj = "Merhaba," & "<br><br>" & "Mail gövdesinde görmek istediniz mesajı buraya yazınız." & "<br><br>" & _
            "İyi çalışmalar dileriz."
  
    Mesaj = "<p style='color:black;font-family:Arial;font-size:13.5'>" & Mesaj & "</font></p>"
  
    With Yeni_Mail
        .Display
        .To = "Göndermek istediğiniz mail adresini yazınız."
        .Cc = ""
        .Bcc = ""
        .Subject = "Mail konusunu buraya yazınız."
        .HTMLBody = Mesaj & .HTMLBody
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
  
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkür ederim Korhan bey, her filtre için yeni bir modul açıp bu kodu değiştirmem gerekiyor sanırım ?

With S1
.Range("A1:C" & .Rows.Count).AutoFilter Field:=1, Criteria1:="satın alma"
.Range("A1").CurrentRegion.Copy
End With

Korhan Ayhan · 22 Şubat 2021

Tabi ki hayır.

Bahsettiğiniz yöntem çok yanlış bir yöntemdir.

Bunun yerine filtre kriterini veri doğrulama-liste özelliği olan bir hücreye bağlayabilirsiniz.

s4kinqz · 22 Şubat 2021

Korhan Ayhan' Alıntı:
Tabi ki hayır.

Bahsettiğiniz yöntem çok yanlış bir yöntemdir.

Bunun yerine filtre kriterini veri doğrulama-liste özelliği olan bir hücreye bağlayabilirsiniz.

Anladım Korhan bey desteğiniz için teşekkür ederim.

omarpz · 24 Şubat 2021

Benim bir makrom var. Kişileri filtreliyorum ve tablo olarak gönderiyorum. Fakat bunu excel olarak göndermek istiyorum. Aşağıdaki koda uygun bir şekilde düzenleyebilir misiniz?


Sub Makro1()
'
' Makro1 Makro
'
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set rng = Nothing
    Set rng = Sheets("VERİ").UsedRange
    'You can also use a sheet name
    'Set rng = Sheets("YourSheet").UsedRange

   Metin = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
                & "Merhaba " & Sheets("ANA SAYFA").Range("C1").Value & "," & "<br>" _
                & "<br>" _
                & vbCrLf & Sheets("ANA SAYFA").Range("J3").Value & "<br> " _
                & "<br>" _
                & vbCrLf & Sheets("ANA SAYFA").Range("J5").Value & "<br> " _
                & "<br>" _
                & vbCrLf & Sheets("ANA SAYFA").Range("J7").Value & "<br> " _
                 & "<br>" _
                & vbCrLf & Sheets("ANA SAYFA").Range("J9").Value & "<br> " _
                 & "<br>" _
                & vbCrLf & Sheets("ANA SAYFA").Range("J11").Value & "<br> " _
                & xSrc _
                & "<br></font></span>"
               
    Metin2 = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
                & "İyi Çalışmalar." & "<br>" _
                & xSrc _
                & "<br></font></span>"

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .Display
        .To = Sheets("ANA SAYFA").Range("B1").Value
        .Cc = ""
        .Bcc = ""
        .Subject = Sheets("ANA SAYFA").Range("J1").Value
        .HTMLBody = Metin & RangetoHTML(rng) & Metin2 & .HTMLBody
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

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

Korhan Ayhan · 24 Şubat 2021

#2 nolu mesajımda paylaştığım kod zaten sizin istediğiniz işlemi yapıyor. Sadece kendinize göre uyarlamasını yapacaksınız.

omarpz · 24 Şubat 2021

Korhan Ayhan' Alıntı:
#2 nolu mesajımda paylaştığım kod zaten sizin istediğiniz işlemi yapıyor. Sadece kendinize göre uyarlamasını yapacaksınız.

yapamadığımdan dolayı destek istemiştim aslında. Belirttiğim kodlara sadece tablo olarak değilde ek olarak gönderilmesi konusunda yardımcı olur musunuz?

omarpz · 25 Şubat 2021

omarpz' Alıntı:
Benim bir makrom var. Kişileri filtreliyorum ve tablo olarak gönderiyorum. Fakat bunu excel olarak göndermek istiyorum. Aşağıdaki koda uygun bir şekilde düzenleyebilir misiniz?

Sub Makro1() ' ' Makro1 Makro ' Dim rng As Range Dim OutApp As Object Dim OutMail As Object With Application .EnableEvents = False .ScreenUpdating = False End With Set rng = Nothing Set rng = Sheets("VERİ").UsedRange 'You can also use a sheet name 'Set rng = Sheets("YourSheet").UsedRange Metin = "" _ & "" _ & "Merhaba " & Sheets("ANA SAYFA").Range("C1").Value & "," & " " _ & " " _ & vbCrLf & Sheets("ANA SAYFA").Range("J3").Value & " " _ & " " _ & vbCrLf & Sheets("ANA SAYFA").Range("J5").Value & " " _ & " " _ & vbCrLf & Sheets("ANA SAYFA").Range("J7").Value & " " _ & " " _ & vbCrLf & Sheets("ANA SAYFA").Range("J9").Value & " " _ & " " _ & vbCrLf & Sheets("ANA SAYFA").Range("J11").Value & " " _ & xSrc _ & " " Metin2 = "" _ & "" _ & "İyi Çalışmalar." & " " _ & xSrc _ & " " Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .Display .To = Sheets("ANA SAYFA").Range("B1").Value .Cc = "" .Bcc = "" .Subject = Sheets("ANA SAYFA").Range("J1").Value .HTMLBody = Metin & RangetoHTML(rng) & Metin2 & .HTMLBody .Display End With On Error GoTo 0 With Application .EnableEvents = True .ScreenUpdating = True End With Set OutMail = Nothing Set OutApp = Nothing End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2016 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" 'Copy the range and create a new workbook to past the data in 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 'Publish the sheet to a htm file 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 'Read all data from the htm file into RangetoHTML 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=") 'Close TempWB TempWB.Close savechanges:=False 'Delete the htm file we used in this function Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function

yardımcı olur musunuz?

omarpz · 2 Mart 2021

Korhan bey, hazırlamış olduğum makroya sadece excel olarak kaydet ve gönder kısmını nasıl ekleyebilirim?

Korhan Ayhan · 3 Mart 2021

Örnek dosyanızı paylaşınız.

omarpz · 5 Mart 2021

Merhaba korhan bey, link aşağıdadır. Çok teşekkür ederim.
https://dosya.co/o67j7oeoel25/MAİL_MAKRO.xlsm.html

omarpz · 7 Mart 2021

Korhan bey desteğinizi rica ederim

Korhan Ayhan · 7 Mart 2021

Tablo olarak mail gövdesine eklenme durumu iptal mi olacak?

omarpz · 7 Mart 2021

Evet korhan bey, sadece tablo olarak değilde excel olarak ayrı ayrı personellermle paylaşacağım. Çok teşekkür ederim ?

Korhan Ayhan' Alıntı:
Tablo olarak mail gövdesine eklenme durumu iptal mi olacak?

Korhan Ayhan · 7 Mart 2021

Mail gönderimi için sadece bu kodu kullanabilirsiniz. Diğerlerine ihtiyacınız kalmamış oldu.

Kodun içindeki '.Send satırının başındaki tek tırnağı kaldırırsanız mailler direkt olarak gönderilir. Ben oluşan mailleri görebilmeniz için pasif bıraktım.

C++:

Option Explicit

Sub Filtrelenmiş_Verileri_Mail_Gonder()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Uygulama As Object, Yeni_Mail As Object
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dosya_Adi As String, Mesaj As String
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
    Set S3 = Sheets("ARA VERİLER")
    
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
   
    Set Uygulama = CreateObject("Outlook.Application")
    
    Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S3.Range("A2:C" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
        
            With S2
                .Range("A1:E" & .Rows.Count).AutoFilter Field:=1, Criteria1:=Veri(X, 1)
                .Range("A1").CurrentRegion.Copy
            End With
   
            Workbooks.Add (1)
            ActiveSheet.Paste
            Columns.AutoFit
            Range("A1").Select
            
            Application.DisplayAlerts = False
            Dosya_Adi = ThisWorkbook.Path & Application.PathSeparator & Veri(X, 1) & ".xlsx"
            ActiveWorkbook.SaveAs Dosya_Adi, 51
            ActiveWorkbook.Close
            Application.DisplayAlerts = True
            
            On Error Resume Next
            S2.ShowAllData
            On Error GoTo 0
            
            Set Yeni_Mail = Uygulama.CreateItem(0)
                   
            Mesaj = "Merhaba " & Veri(X, 1) & "," & "<br><br>" & S1.Range("J3").Value & "<br>" & _
                    "<br>" & S1.Range("J5").Value & "<br>" & _
                    "<br>" & S1.Range("J7").Value & "<br>" & _
                    "<br>" & S1.Range("J9").Value & "<br>" & _
                    "<br>" & S1.Range("J11").Value & "<br><br>" & _
                    "İyi çalışmalar."
   
            Mesaj = "<p style='color:black;font-family:Calibri;font-size:13.5'>" & Mesaj & "</font></p>"
   
            With Yeni_Mail
                .Display
                .To = Veri(X, 3)
                .Cc = "pivazovski@hotmail.com"
                .Bcc = ""
                .Subject = S1.Range("J1").Value
                .HTMLBody = Mesaj & .HTMLBody
                .Attachments.Add Dosya_Adi
                .BodyFormat = 2
                .Save
                '.Send
            End With
        End If
    Next
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

omarpz · 9 Mart 2021

Elinize sağlk korhan bey

omarpz · 11 Nisan 2021

Korhan bey tekrardan merhaba,

yaptığınız kod gayet sağlıklı çalışıyor bunun için teşekkür ederim.

Ek olarak exceli maile ekledikten sonra masaüstünden silsin istiyorum.

Ayrıca mail başlangıcı merhaba “kullanıcı adı” şeklinde oluyor. Sayfa 3de a sütununda kullanıcı adlarının kime ait olduğu b sütununda yer alıyor. Mail başlangıcı Merhaba “ İsim “ şeklinde olması mümkün müdür?

Korhan Ayhan · 11 Nisan 2021

Sayfa3 dediğiniz sanırım "ARA VERİLER" isimli sayfa oluyor.

Deneyiniz.

C++:

Option Explicit

Sub Filtrelenmiş_Verileri_Mail_Gonder()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Uygulama As Object, Yeni_Mail As Object
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dosya_Adi As String, Mesaj As String
  
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("VERİ")
    Set S3 = Sheets("ARA VERİLER")
   
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
   
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
  
    Set Uygulama = CreateObject("Outlook.Application")
   
    Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
   
    Veri = S3.Range("A2:C" & Son).Value
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
       
            With S2
                .Range("A1:E" & .Rows.Count).AutoFilter Field:=1, Criteria1:=Veri(X, 1)
                .Range("A1").CurrentRegion.Copy
            End With
  
            Workbooks.Add (1)
            ActiveSheet.Paste
            Columns.AutoFit
            Range("A1").Select
           
            Application.DisplayAlerts = False
            Dosya_Adi = ThisWorkbook.Path & Application.PathSeparator & Veri(X, 1) & ".xlsx"
            ActiveWorkbook.SaveAs Dosya_Adi, 51
            ActiveWorkbook.Close
            Application.DisplayAlerts = True
           
            On Error Resume Next
            S2.ShowAllData
            On Error GoTo 0
           
            Set Yeni_Mail = Uygulama.CreateItem(0)
                  
            Mesaj = "Merhaba " & Veri(X, 2) & "," & "<br><br>" & S1.Range("J3").Value & "<br>" & _
                    "<br>" & S1.Range("J5").Value & "<br>" & _
                    "<br>" & S1.Range("J7").Value & "<br>" & _
                    "<br>" & S1.Range("J9").Value & "<br>" & _
                    "<br>" & S1.Range("J11").Value & "<br><br>" & _
                    "İyi çalışmalar."
  
            Mesaj = "<p style='color:black;font-family:Calibri;font-size:13.5'>" & Mesaj & "</font></p>"
  
            With Yeni_Mail
                .Display
                .To = Veri(X, 3)
                .Cc = "pivazovski@hotmail.com"
                .Bcc = ""
                .Subject = S1.Range("J1").Value
                .HTMLBody = Mesaj & .HTMLBody
                .Attachments.Add Dosya_Adi
                .BodyFormat = 2
                .Save
                '.Send
            End With

            Kill Dosya_Adi
        End If
    Next
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

omarpz · 11 Nisan 2021

Korhan bey,
İsim kısmı çözüldü fakat makroyu çalıştırdığımda run-time error’53’ file not found hatası vermektedir.
Maile eklenen exceli silmede bir problem yaşanıyor sanırım.

Excel Sayfasını Mail Olarak Gönderme

s4kinqz

Ekli dosyalar

Korhan Ayhan

Administrator

s4kinqz

Korhan Ayhan

Administrator

s4kinqz

omarpz

Korhan Ayhan

Administrator

omarpz

omarpz

omarpz

Korhan Ayhan

Administrator

omarpz

omarpz

Korhan Ayhan

Administrator

omarpz

Korhan Ayhan

Administrator

omarpz

omarpz

Korhan Ayhan

Administrator

omarpz