• DİKKAT

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

Farklı verileri kopyalayıp, otomatik mail atma

K

Krall16

Katılım
24 Şubat 2015
Mesajlar
16
Excel Vers. ve Dili
Microsoft Office Pro Plus 2010
Merhaba,

Belli bir alanı seçip otomatik mail atılan kodlar yaygın olarak bulunabilmekte. Ancak benim ihtiyacım olan, farklı sekmede farklı alanları kopyalayıp, belirli başlıklar altında otomatik mail atacak bir excel. Bu konuda yardımcı olabilir mi kodlamaya hakim olan arkadaşlar?

Talebimin detayları:

4 sekme düşünelim. a, b, c ve d sekmeleri.

Mail'in ne şekilde olacağını belirtirsem, ihtiyacım çok daha net olacaktır;

"Merhaba,

İlgili veriler aşağıdadır.

A'nın verileri;

(Bu alana excel'de A sekmesinde A14:G24 aralığından veri getirecek. Ancak veri pivot tabanlı olduğu için satır sayısı değişecektir. Bu sebeple, A14'den itibaren aşağıya doğru dolu satır sayısını kontrol edip, G sütununu buna göre G24 veya G25 diye kendi arttırabilmeli)

B'nin verileri;

(üsttekinin aynısı B sekmesi için)

C'nin verileri;

(üsttekinin aynısı C sekmesi için)

d'nin verileri;

(üsttekinin aynısı D sekmesi için)


Bilginize sunarım.

Saygılarımla"

Mail'in kimlere gideceğini örneğin A sekmesinde Y2 hücresinden ve mail'in konu başlığını da örneğin gene A sekmesinde Z2 hücresinden alsın.

Bu tarz parça parça veri alacak olması benim bilgimi aşıyor maalesef. Bilen arkadaşlar yardımcı olurlarsa sevinirim. Şimdiden teşekkürler.
 
Asıl dosyanıza benzer bir örnek dosya eklerseniz verilerin nereden alacağı sıkıntısı olmaz. Hemde kod yazılacak zamana bir de excel şablon hazırlama vakti eklenmemiş olur. Sizin içinde hazır kod olur.
 
Linkte en alttaki küçük yazılı indir i tıklayın. Büyük olanı değil.

http://dosya.co/dva2t44b7kwk/coklu_alan_mail_gonder.xlsm.html


Kod: 
Dim mail, konu, mesaj As String
Dim wrdEdit
Dim alana, alanb, alanc, aland As Range

Sub menu()
    Sheets("Menu").Select
    mail = [G3]
    konu = [G4]
    mesaj = [G5]
    mesaj = Replace(mesaj, ",", ", <br>")
    Call mail_gonder
End Sub

Sub mail_gonder()

      
      sonsatir = Sheets("A").Cells(Rows.Count, "A").End(3).Row
      Set alana = Sheets("A").Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("B").Cells(Rows.Count, "A").End(3).Row
      Set alanb = Sheets("B").Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("C").Cells(Rows.Count, "A").End(3).Row
      Set alanc = Sheets("C").Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("D").Cells(Rows.Count, "A").End(3).Row
      Set aland = Sheets("D").Range("A14:G" & sonsatir)
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = mail
       .CC = ""
       .Subject = konu
       .Display
       
       .HTMLBody = mesaj & _
          "<br>" & "A'nın verileri;" & "<br>" & RangetoHTML(alana) & _
          "<br>" & "B'nın verileri;" & "<br>" & RangetoHTML(alanb) & _
          "<br>" & "C'nın verileri;" & "<br>" & RangetoHTML(alanc) & _
          "<br>" & "D'nın verileri;" & "<br>" & RangetoHTML(aland) & _
         .HTMLBody
        
        'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
        '.send
       End With
      
      Set wrdEdit = Nothing
      Set OutMail = Nothing
      Set OutApp = Nothing
End Sub

Function RangetoHTML(rng)
' 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
 
askm' Alıntı:
Asıl dosyanıza benzer bir örnek dosya eklerseniz verilerin nereden alacağı sıkıntısı olmaz. Hemde kod yazılacak zamana bir de excel şablon hazırlama vakti eklenmemiş olur. Sizin içinde hazır kod olur.
Genişletmek için tıkla ...

Eleştiriniz&öneriniz için teşekkür ederim. Gelecekte dediğiniz şekilde yapacağım. Doğrudan hücre adı vermemin, sizlerin şablon hazırlamasına gerek olmadan doğrudan kod yazabileceğine imkan tanıdığını düşünerek, bu yolla işinizi daha da kolaylaştıracağımı düşünüyordum açıkçası.

İlginiz için teşekkürler.

asri' Alıntı:
Linkte en alttaki küçük yazılı indir i tıklayın. Büyük olanı değil.

http://dosya.co/dva2t44b7kwk/coklu_alan_mail_gonder.xlsm.html


Kod: 
Dim mail, konu, mesaj As String
Dim wrdEdit
Dim alana, alanb, alanc, aland As Range

Sub menu()
    Sheets("Menu").Select
    mail = [G3]
    konu = [G4]
    mesaj = [G5]
    mesaj = Replace(mesaj, ",", ", <br>")
    Call mail_gonder
End Sub

Sub mail_gonder()

      
      sonsatir = Sheets("A").Cells(Rows.Count, "A").End(3).Row
      Set alana = Sheets("A").Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("B").Cells(Rows.Count, "A").End(3).Row
      Set alanb = Sheets("B").Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("C").Cells(Rows.Count, "A").End(3).Row
      Set alanc = Sheets("C").Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("D").Cells(Rows.Count, "A").End(3).Row
      Set aland = Sheets("D").Range("A14:G" & sonsatir)
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = mail
       .CC = ""
       .Subject = konu
       .Display
       
       .HTMLBody = mesaj & _
          "<br>" & "A'nın verileri;" & "<br>" & RangetoHTML(alana) & _
          "<br>" & "B'nın verileri;" & "<br>" & RangetoHTML(alanb) & _
          "<br>" & "C'nın verileri;" & "<br>" & RangetoHTML(alanc) & _
          "<br>" & "D'nın verileri;" & "<br>" & RangetoHTML(aland) & _
         .HTMLBody
        
        'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
        '.send
       End With
      
      Set wrdEdit = Nothing
      Set OutMail = Nothing
      Set OutApp = Nothing
End Sub

Function RangetoHTML(rng)
' 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
Genişletmek için tıkla ...

Emeğinize sağlık, hızınız için ayrıca teşekkür ederim. Ufak 1-2 sorun yaşıyorum, ancak benden kaynaklı olsa gerek, halledeceğim. Aşamazsam, tekrar destek talep edebilirim.

İlginize, çabanıza ve desteğinize ayrı ayrı teşekkür ederim.
 
Tekrar merhaba,

Belirttiğiniz kodu bir tuşa ekleyeceğim zaman ne şekilde yapmam gerekiyor? Kodun "Private Sub CommandButton1_Click()" ve "end sub" kodları arasına alırsam, sanırım en baştaki alan dolayısıyla olsa gerek, "compile error: Expected end sub" hatası alıyorum. Anladığım kadarıyla en baştaki "private sub"ın sonunu kestiremiyor. Ne yolla uygulamam gerekmekte? Aslında ilk çalıştırdığımda kod çalıştı. Ancak 2. seferden itibaren sorun yaşadım maalesef.
 
Krall16' Alıntı:
Tekrar merhaba,

Belirttiğiniz kodu bir tuşa ekleyeceğim zaman ne şekilde yapmam gerekiyor? Kodun "Private Sub CommandButton1_Click()" ve "end sub" kodları arasına alırsam, sanırım en baştaki alan dolayısıyla olsa gerek, "compile error: Expected end sub" hatası alıyorum. Anladığım kadarıyla en baştaki "private sub"ın sonunu kestiremiyor. Ne yolla uygulamam gerekmekte? Aslında ilk çalıştırdığımda kod çalıştı. Ancak 2. seferden itibaren sorun yaşadım maalesef.
Genişletmek için tıkla ...

Kodu içeren dosyayı eklemiştim.

Kodu sayfanızda VBA bölümünde MODUL1 in içine yapıştırın.
Modul1 yok ise sağ tuş insert modul diyerek ekleyin.

Sonra sayfaya geliştirici bölümünde ekle form nesesi buton diyerek buton ekleyip sağ tuş makro ata ile menu makarosunu ekleyin.

Dosyanızın menu sayfası bulunmalı.

Bu sorunların hepsi örnek dosya paylaşmadığınız için yaşanmaktadır. :)
Örnek dosya her zaman paylaşılmalı.
 
Deniyorum, teşekkür ederim. Hızınız için ayrıca bir "maşaallah" demek istiyorum :)

Bu yazışmaları iş yerinden gerçekleştirmekteyim. Dosyanızı gördüm, sorunumu da çözecekti muhtemelen, ancak maalesef hem kural gereği, hem IT tarafından dosya transferimiz engellenmekte (güvenlik dolayısıyla). Bu sebeple paylaştığınız kod üzerinden ilerledim. Gelecekte bir sorum olduğunda mutlaka dosya paylaşmaya çalışacağım. Eleştiriniz&öneriniz için teşekkürler
 
Denerken farkettim, dediğiniz yöntemi dün denemiştim. Ancak makro ata deyince, "mail_gonder" ve "menu" diye 2 seçenek çıkmakta. İkisi de sizin makronuzla ilgili, dolayısıyla ikisini de ayrı ayrı denemiştim. Bugün tekrar denedim ve gene aşağıdaki hatayı aldım;

Run-time error '9':

Subscript out of range

Bu vesileyle;

Dosyamın menüsü bulunmalı derken neyi kastettiniz acaba? Mesajınızda sadece bu ifadede neyi kastettiğinizi anlayamadım maalesef. Cevabınız için şimdiden teşekkür ederim.
 
1 saniye, bir şey deniyorum, benim hatam olabilir.
 
Her şey için tekrar teşekkür ederim. Sorunsuz çalışıyor şu an :)

İyi günler dilerim.
 
Merhaba,

Kodları başka birkaç formata uyarladım. Geniş olan (P sütununa kadar giden) bir tabloda mail'e yapıştırırken ister istemez görünüm bozuluyor kodda. Aynı koda "resim olarak yapıştır" uyarlamasını nasıl yapabilirim? Basit bir şey olmalı herhalde ama internette aradığımda bulduğum kodlamalar çok farklı çıktı ve uyarlayamadım maalesef. Yardım edebilecek biri olursa çok sevinirim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst