• DİKKAT

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

Mail olarak gönderilecek veriye başlık ekleme

S

Sinan2618

Katılım
17 Ağustos 2016
Mesajlar
118
Excel Vers. ve Dili
2013 Türkçe
Merhaba,

uzun süredir üstünde çalıştığım bir excel mail tablom var. en son hali ekteki gibidir. şuan mail gönder butonuna tıklandığında makroda seçilmiş olan sutünların 2. satırında bulunan yazılar girilmiş olan mail adresine gönderilmektedir. ben burada sutünlarda bulunan başlıklarıda eklemek istiyorum. desteğiniz ricadır.

Anlatabildim mi bilmiyorum ama aşağıdaki gibi olsun istiyorum. Ayrıca bu dosyayı bu şekile getirmemde emeği geçen @askm 'ye teşekkürü borç bilirim.

Başlık 1 Başlık 2 Başlık 3 Başlık 4
Deneme 1 Deneme 2 Deneme 3 Deneme 4

Teşekkürler.
 

Ekli dosyalar

Merhaba,

Tam olarak istediğiniz gibi mail alanında gözükmesi için(her başlık altında hizalı gelmesi için) alanı kopyalamak gerekir. Buda tamamen farklı bir metot dur. Tekrardan düzenlemek gerekir.

Kopyalamadan yapılırsa veriler alt alta gelmez karışıklık olur. Yada uzunlukları ayarlamak için kodları uzatmak gerekir.

Bence istediğinizi kısa yoldan yapmak için alt alta değil, yana yana gelecek şekilde yazmak daha mantıklı.

Deneyin sonuçlara göre ilerleyebiliriz.

Kod: 
.Body = Cells(H, "B").Value & " " & Cells(H, "C").Value & " " & Cells(H, "D").Value & " " & Cells(H, "E").Value

Kodların içinde bulunan, yukarıdaki satırı silip aşağıdaki satırı ekleyip deneyin.

Kod: 
Dim j As Byte, a As String, deg As String
For j = 2 To 6 ' B ile F sütunu arası
    a = Chr(10)
    If deg = "" Then a = ""
    deg = deg & a & Cells(1, j) & ":  " & Cells(H, j)
Next j

.Body = deg

.
 
Alternatif;

Sayfadaki bilgileri sayfadaki görüntüsü ile eklemek isterseniz aşağıdaki kodu kullanabilirsiniz.

Kod: 
Sub Mail_Gonder()
    Dim Alan As Range, Son As Long, Satir As Long, X As Long
    Dim Uygulama As Object, Yeni_Mail As Object
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    ActiveSheet.Cells.EntireColumn.AutoFit
    On Error GoTo 0
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set Uygulama = CreateObject("Outlook.Application")
        
    For X = 2 To Son
        If WorksheetFunction.CountIf(Range("A2:A" & X), Cells(X, 1)) = 1 And Cells(X, 1) Like "*@*" Then
            ActiveSheet.Range("A1:F" & Rows.Count).AutoFilter Field:=1, Criteria1:=Cells(X, 1).Value
            
            Satir = Cells(Rows.Count, 1).End(3).Row
            
            Set Alan = Nothing
            On Error Resume Next
            Set Alan = Range("B1:F" & Satir)
            On Error GoTo 0
        
            Alan.Copy
        
            Set Yeni_Mail = Uygulama.CreateItem(0)
            
            On Error Resume Next
            With Yeni_Mail
                '.Display
                .To = Cells(X, 1).Value
                .CC = ""
                .BCC = ""
                .Subject = "Stop, Fiyat ve Aksiyon"
                .HTMLBody = RangetoHTML(Alan)
                .Send
            End With
            On Error GoTo 0
        End If
    Next

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

    On Error Resume Next
    ActiveSheet.ShowAllData
    ActiveSheet.Cells.EntireColumn.AutoFit
    On Error GoTo 0

    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
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
 
Korhan Ayhan' Alıntı:
Alternatif;

Sayfadaki bilgileri sayfadaki görüntüsü ile eklemek isterseniz aşağıdaki kodu kullanabilirsiniz.

Kod: 
Sub Mail_Gonder()
    Dim Alan As Range, Son As Long, Satir As Long, X As Long
    Dim Uygulama As Object, Yeni_Mail As Object
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    ActiveSheet.Cells.EntireColumn.AutoFit
    On Error GoTo 0
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set Uygulama = CreateObject("Outlook.Application")
        
    For X = 2 To Son
        If WorksheetFunction.CountIf(Range("A2:A" & X), Cells(X, 1)) = 1 And Cells(X, 1) Like "*@*" Then
            ActiveSheet.Range("A1:F" & Rows.Count).AutoFilter Field:=1, Criteria1:=Cells(X, 1).Value
            
            Satir = Cells(Rows.Count, 1).End(3).Row
            
            Set Alan = Nothing
            On Error Resume Next
            Set Alan = Range("B1:F" & Satir)
            On Error GoTo 0
        
            Alan.Copy
        
            Set Yeni_Mail = Uygulama.CreateItem(0)
            
            On Error Resume Next
            With Yeni_Mail
                '.Display
                .To = Cells(X, 1).Value
                .CC = ""
                .BCC = ""
                .Subject = "Stop, Fiyat ve Aksiyon"
                .HTMLBody = RangetoHTML(Alan)
                .Send
            End With
            On Error GoTo 0
        End If
    Next

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

    On Error Resume Next
    ActiveSheet.ShowAllData
    ActiveSheet.Cells.EntireColumn.AutoFit
    On Error GoTo 0

    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
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
Genişletmek için tıkla ...

Korhan bey çok teşekkürler peki c sütunünu göndermemek için ne yapmam lazım burada b'den f'ye kadar hepsini gönderiyor. Örneğin B, D, E ve F sutünlarını göndermesi için kod'un neresinde güncelleme yapmam gerekir?
 
Gönderilmek istenmeyen sütunlar gizlenir ve sonra mail olarak gönderilebilir.
 
Kod içinde geçen aşağıdaki satırdan önce;

Kod: 
Alan.Copy

Alttaki satırı eklerseniz istediğiniz sonuca ulaşabilirsiniz.

Kod: 
Columns(3).Hidden = True
 
Korhan Ayhan' Alıntı:
Kod içinde geçen aşağıdaki satırdan önce;

Kod: 
Alan.Copy

Alttaki satırı eklerseniz istediğiniz sonuca ulaşabilirsiniz.

Kod: 
Columns(3).Hidden = True
Genişletmek için tıkla ...

Korhan bey teşekkürler. Aynı şeyi mantık yürüterek satırlar için aşağıdaki kodla denedim olmadı :) Sizin bir çözümünüz var mı?

Kod: 
Rows(3).Hidden = True
 
Korhan Ayhan' Alıntı:
Kod içinde geçen aşağıdaki satırdan önce;

Kod: 
Alan.Copy

Alttaki satırı eklerseniz istediğiniz sonuca ulaşabilirsiniz.

Kod: 
Columns(3).Hidden = True
Genişletmek için tıkla ...

Korhan bey, Columns(3) olarak girdiğimiz kod sanırım 3. sütunu gizlemek için geçerli. benim excel üzerinden gizleyeceğim satır ve sütunları filtreleme ve gizlemi işlemi yaparak gönderebileceğim bir çözüm var mıdır?
 
Kod zaten "A" sütunundaki mail adreslerini filtreleyerek mail gönderiyor. Bu esnada gereksiz satırlar gizlenmiş oluyor.

Siz bunun dışında mı satır gizlemek istiyorsunuz. Eğer öyleyse hangi mail adresinde satırlar gizlenecek?
 
Korhan Ayhan' Alıntı:
Kod zaten "A" sütunundaki mail adreslerini filtreleyerek mail gönderiyor. Bu esnada gereksiz satırlar gizlenmiş oluyor.

Siz bunun dışında mı satır gizlemek istiyorsunuz. Eğer öyleyse hangi mail adresinde satırlar gizlenecek?
Genişletmek için tıkla ...

Haklısınız saklanmak istenen satırlara mail yazmayınca gitmez. Bunu atladım birden fazla sütun saklamak için kodu örnek olarak aşağıdaki şekilde uyguladım sorun olmadı.

Kod: 
Columns(3).Hidden = True
Columns(4).Hidden = True
Columns(5).Hidden = True
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst