excelde seçili sütunları email gönderme

mustilem23 · 25 Aralık 2015

Merhabalar kolay gelsin ,

outlok 2010 kullanıyorum ,excel de a dan m sütunu dahil satır sayısı MAX (50) buradaki verileri outlok yazım sayfasına kopyalamak ve altına siparişimiz dir yazdırıp,mail konu başlığına a sütunundaki veriyi yazarak belirli email gurubuna email atmak istiyorum yardımcı olabilirmisiniz günde ortalama 50 defa bu işlemi yapıyorum ,benzer konuları araştırdım fakat vba bilgim olmadığı için okunlar ile bu konuyu pekiştiremedim,yardımcı olabilirseniz çok makbule geçecek.

örnek resim.
https://www.wetransfer.com/downloads/8dc226842d26aded0c5ce9d8913dcbbb20151225144849/6c2a49c9684c9500b9b5eda71045136e20151225144849/18a7d1

mustilem23 · 28 Aralık 2015

günaydınlar,
konu hakkında yardımcı olabilir misiniz .

mustilem23 · 29 Aralık 2015

rahatsız ediyorum tekrar ama yardımcı olabilir misiniz.

mustilem23 · 5 Şubat 2016

yarımcı olabilir misiniz arkadaşlar bu konuya çok ihtiyacım var

Mehmet Şahin · 5 Şubat 2016

Dosyanız indirilemiyor.

Korhan Ayhan · 8 Şubat 2016

Örnek dosyanızı aşağıdaki paylaşım sitesine yükleyip bağlantı verirseniz yardımcı olabiliriz.

http://www.dosya.tc

mustilem23 · 8 Şubat 2016

Örnek dosyalarım ekteki gibidir excel dosyasında yapmaya çalıştıklarımı anlatmaya calıştım yardımlarınızı rica ederim

http://s8.dosya.tc/server/kdzqxp/secili_sutun_email_gonderme.xlsx.html

*http://s8.dosya.tc/server/q3en24/2736_siparisimizdir.jpg.html

PLİNT · 9 Şubat 2016

Merhaba
Ek dosyayı bir deneyelim;
Sütun genişlikleri örnekteki gibi;verilerin tam sığacağı şekilde olmalıdır.
http://s8.dosya.tc/server/bwu5ne/secili_sutun_email_gonderme.zip.html

Kod:

Sub mail()
 Dim hcr As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim act As Worksheet
    Set hcr = Nothing
    Set act = ActiveSheet
On Error Resume Next
Set hcr = act.Range("A3:m" & act.Cells(Rows.Count, "A").End(3).Row)
On Error GoTo 0
Application.EnableEvents = False
Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "mcesur@firmaısmı.com;satınalma@firmaismi.com"
        .CC = ""
        .BCC = ""
        .Subject = Replace(act.Range("A2").Text, "*", "")
        .BodyFormat = 2
        .HTMLBody = vrhtml(hcr)
        .Save
        '.........................
        '.Send  '..........GÖNDERMEK İÇİN
        '............
        .Display
    End With
    On Error GoTo 0
Application.EnableEvents = True
        Application.ScreenUpdating = True
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Kod:

Function vrhtml(hcr As Range)
    Dim fs As Object
    Dim ts As Object
    Dim kyt As String
    Dim ktp, bu As Workbook
    Dim n As Integer
    Dim act2 As Worksheet
    kyt = ThisWorkbook.Path & "\" & "yeni" & ".htm"
    hcr.Copy
Set bu = ThisWorkbook
Set act2 = ThisWorkbook.ActiveSheet

Set ktp = Workbooks.Add(1)
    With ktp.Sheets(1)
        .Cells(1).PasteSpecial
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    For n = 1 To 13
ktp.Sheets(1).Columns(n).ColumnWidth = act2.Columns(n).ColumnWidth
Next

ktp.Sheets(1).UsedRange.Borders.Weight = xlThin
 ktp.Sheets(1).Range("A" & ktp.Sheets(1).Cells(Rows.Count, "A").End(3).Row + 2) = "Sparişimiz dir"
    With ktp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=kyt, _
         Sheet:=ktp.Sheets(1).Name, _
         Source:=ktp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ts = fs.GetFile(kyt).OpenAsTextStream(1, -2)
    vrhtml = ts.readall
    ts.Close
    vrhtml = Replace(vrhtml, "align=center x:publishsource=", "align=left x:publishsource=")
    ktp.Close savechanges:=False
    Kill kyt
    Set ts = Nothing
    Set fs = Nothing
    Set ktp = Nothing
End Function

mustilem23 · 9 Şubat 2016

Sayın PLİNT elinize sağlık süper çalışıyor ,fakat 2 küçük nokta var ,

1 makroyu kaydedip tüm exceller de çalıştıramıyorum ,(vısual basıc de kod ekleyıp run dediğimde çalısıyor) tüm excellerde nasıl çalıştırabilirim .

2 hücre biçimlendirmeden yazım ekranına kopyalıyor satır ve sütunları kareler içine alabilir mi ?

yardımcı olabilirseniz çok makbule geçecek.

PLİNT · 10 Şubat 2016

mustilem23' Alıntı:
Sayın PLİNT elinize sağlık süper çalışıyor ,fakat 2 küçük nokta var ,

1 makroyu kaydedip tüm exceller de çalıştıramıyorum ,(vısual basıc de kod ekleyıp run dediğimde çalısıyor) tüm excellerde nasıl çalıştırabilirim .
2 hücre biçimlendirmeden yazım ekranına kopyalıyor satır ve sütunları kareler içine alabilir mi ?

Merhaba
1. istediğiniz aktif sayfa,
2. istediğiniz asıl dosyanızda kenarlık yok ve kenarlık eklenmesi ise;
Yukarıdaki değişen kod ve ek dosyayı deneyiniz.

mustilem23 · 11 Şubat 2016

Sayın PLİNT ,

Elinize sağlık oldu sizin gönderdiğiniz exceli açıyorum ,
bizim firmanın programından yazıları excele çıkarttırıyorum ve makro görüntüle dediğim de çıkıyor çalıştır deyince çalışıyor cok teşekkürler,

makro konusun da çok yeniyimde (sanırım arka planda çalışan bir program mantığı

) ben sanıyordum bir excelin içine kaydettiğimde makroyu kapattığım da tüm yeni excellerde kullanılabilir durumda olduğunu düşünmüştüm ilginiz için çok teşekkür ederim epey işim kolaylaştıracak

PLİNT · 11 Şubat 2016

mustilem23' Alıntı:
(sanırım arka planda çalışan bir program mantığı ) ben sanıyordum bir excelin içine kaydettiğimde makroyu kapattığım da tüm yeni excellerde kullanılabilir durumda olduğunu düşünmüştüm ilginiz için çok teşekkür ederim epey işim kolaylaştıracak

Merhaba
Kodları eklediğiniz excel dosyalarında çalışacaktır, mantığı; aktif olan sayfa
kod yardımıyla yeni oluşturulan excel dosyasına aktarılıp "html" olarak kaydedilecek
buradan "outlook" a aldırılıp kod sonunda oluşan excel ve html dosyaları silinecek.

halit3 · 11 Şubat 2016

Alternatif kod
Mail gönderirken mutlaka bir gmail adresiniz olmalı
Aşağıdaki kırmızı yerlere kendi kullanıcı adınızı ve parolanızı yazın ve kodu çalıştırın

Kod:

Sub mailgönder()


Set objEmail = CreateObject("CDO.Message")

kullanici_sahibi = "[COLOR="Red"]kullanıcı@hotmail.com[/COLOR]"
kullanici_parola = "[COLOR="red"]parola[/COLOR]"

objEmail.From = kullanici_sahibi ' Gönderilen e-mail adresi
objEmail.To = "mcesur@firmaısmı.com;satınalma@firmaismi.com" ' Gönderilecek e-mail adresi

objEmail.Subject = Cells(2, 1)

bir1 = "<table <caption></caption><thead><th scope=col abbr=></th></tr></thead><tbody>"

For k = 2 To Cells(Rows.Count, "a").End(3).Row
bir1 = bir1 & "</tr><tr><th scope=row abbr=class=>" & Cells(k, 1) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 2) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 3) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 4) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 5) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 6) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 7) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 8) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 9) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 10) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 11) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 12) & "</th>" & _
"<th class=tabloZRFark>" & Cells(k, 13) & "</th>"
Next
                  
bir1 = bir1 & "</tr><tr><th scope=row abbr=class=>" & son & "</th><th>" & son & "</th></tr><tr>" & _
"</tr></tbody><tfoot><tr><th colspan=1>Teşekkürler</th></tr></tfoot>"

son = "SİPARİŞİMİZ DİR YAZIP "

bir2 = "<table <caption>" & "" & "</caption><thead>" & _
"<th scope=col abbr=" & "" & "class=bgYok>" & "" & "</th></th></tr></thead><tbody>" & _
"</tr></tbody><tfoot><tr><th colspan=1>" & son & "</th></tr></tfoot></table"
objEmail.HTMLBody = "<br>" & bir1 & bir2

'objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı
With objEmail.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = kullanici_sahibi '"kullanıcı@hotmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = kullanici_parola '"parola"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True

.Update

End With
objEmail.Send

MsgBox "işlem tamam.", vbApplicationModal, "Bilgilendirme!"


End Sub

mustilem23 · 15 Şubat 2016

PLİNT' Alıntı:

Merhaba
Ek dosyayı bir deneyelim;
Sütun genişlikleri örnekteki gibi;verilerin tam sığacağı şekilde olmalıdır.
http://s8.dosya.tc/server/bwu5ne/secili_sutun_email_gonderme.zip.html

Kod:

Sub mail()
 Dim hcr As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim act As Worksheet
    Set hcr = Nothing
    Set act = ActiveSheet
On Error Resume Next
Set hcr = act.Range("A3:m" & act.Cells(Rows.Count, "A").End(3).Row)
On Error GoTo 0
Application.EnableEvents = False
Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "mcesur@firmaısmı.com;satınalma@firmaismi.com"
        .CC = ""
        .BCC = ""
        .Subject = Replace(act.Range("A2").Text, "*", "")
        .BodyFormat = 2
        .HTMLBody = vrhtml(hcr)
        .Save
        '.........................
        '.Send  '..........GÖNDERMEK İÇİN
        '............
        .Display
    End With
    On Error GoTo 0
Application.EnableEvents = True
        Application.ScreenUpdating = True
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Kod:

Function vrhtml(hcr As Range)
    Dim fs As Object
    Dim ts As Object
    Dim kyt As String
    Dim ktp, bu As Workbook
    Dim n As Integer
    Dim act2 As Worksheet
    kyt = ThisWorkbook.Path & "\" & "yeni" & ".htm"
    hcr.Copy
Set bu = ThisWorkbook
Set act2 = ThisWorkbook.ActiveSheet

Set ktp = Workbooks.Add(1)
    With ktp.Sheets(1)
        .Cells(1).PasteSpecial
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    For n = 1 To 13
ktp.Sheets(1).Columns(n).ColumnWidth = act2.Columns(n).ColumnWidth
Next

ktp.Sheets(1).UsedRange.Borders.Weight = xlThin
 ktp.Sheets(1).Range("A" & ktp.Sheets(1).Cells(Rows.Count, "A").End(3).Row + 2) = "Sparişimiz dir"
    With ktp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=kyt, _
         Sheet:=ktp.Sheets(1).Name, _
         Source:=ktp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ts = fs.GetFile(kyt).OpenAsTextStream(1, -2)
    vrhtml = ts.readall
    ts.Close
    vrhtml = Replace(vrhtml, "align=center x:publishsource=", "align=left x:publishsource=")
    ktp.Close savechanges:=False
    Kill kyt
    Set ts = Nothing
    Set fs = Nothing
    Set ktp = Nothing
End Function

Sayın plint tekrar rahatsız ediyorum fakat bir sorum olacak biz makroyu a sütunundan m stununa alacak şekilde dizayn etmiştik,söyle bir durum yapılabilir mi ?

a,b,c,d,f,k,m,o sütünları nı alabilir mi , aradaki sütunlar göndereceğim kişiye gerekmiyor her defasında silmem gerekiyor ve sütunları programdan kaydırmam lazım başka işlemler içinde kullanıyorum çünki.

bu konudada yardımcı olabilmeniz mümkün müdür acaba ?

PLİNT · 17 Şubat 2016

mustilem23' Alıntı:
a,b,c,d,f,k,m,o sütünları nı alabilir mi , aradaki sütunlar göndereceğim kişiye gerekmiyor her defasında silmem gerekiyor ve sütunları programdan kaydırmam lazım başka işlemler içinde kullanıyorum çünki.
bu konudada yardımcı olabilmeniz mümkün müdür acaba ?

Merhaba

Kodları aşağıdakilerle değiştirip deneyiniz.
Daha önce belirttiğim gibi "outlook" a göndermeden önce gönderilecek sütunların genişliklerini; içindeki verilerin tam sığacağı şekilde genişletmelisiniz.

Kod:

[SIZE="2"]Private Sub CommandButton1_Click()
 Dim hcr As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim act As Worksheet
    Set hcr = Nothing
    Set act = ActiveSheet
On Error Resume Next
Set hcr = act.Range("A3:O" & act.Cells(Rows.Count, "A").End(3).Row)
On Error GoTo 0
Application.EnableEvents = False
Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "mcesur@firmaısmı.com;satınalma@firmaismi.com"
        .CC = ""
        .BCC = ""
        .Subject = Replace(act.Range("A2").Text, "*", "")
        .BodyFormat = 2
        .HTMLBody = vrhtml(hcr)
        .Save
        '.........................
        '.Send  '..........GÖNDERMEK İÇİN
        '............
        .Display
    End With
    On Error GoTo 0
Application.EnableEvents = True
        Application.ScreenUpdating = True
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub[/SIZE]

Kod:

[SIZE="2"]Function vrhtml(hcr As Range)
    Dim fs As Object
    Dim ts As Object
    Dim kyt As String
    Dim ktp, bu As Workbook
    Dim n As Integer
    Dim act2 As Worksheet
    Dim fc As Variant
    kyt = ThisWorkbook.Path & "\" & "yeni" & ".htm"
    hcr.Copy
Set bu = ThisWorkbook
Set act2 = ThisWorkbook.ActiveSheet

Set ktp = Workbooks.Add(1)
    With ktp.Sheets(1)
        .Cells(1).PasteSpecial
        .Cells(1).Select
    .Columns("E:E").Delete Shift:=xlToLeft
    .Columns("F:I").Delete Shift:=xlToLeft
    .Columns("G:G").Delete Shift:=xlToLeft
    .Columns("H:H").Delete Shift:=xlToLeft

        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    fc = Array(1, 2, 3, 4, 6, 11, 13, 15)
    For n = 0 To UBound(fc)
ktp.Sheets(1).Columns(n+1).ColumnWidth = act2.Columns(fc(n)).ColumnWidth
Next
ktp.Sheets(1).UsedRange.Borders.Weight = xlThin
 ktp.Sheets(1).Range("A" & ktp.Sheets(1).Cells(Rows.Count, "A").End(3).Row + 2) = "Sparişimiz dir"
    With ktp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=kyt, _
         Sheet:=ktp.Sheets(1).Name, _
         Source:=ktp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ts = fs.GetFile(kyt).OpenAsTextStream(1, -2)
    vrhtml = ts.readall
    ts.Close
    vrhtml = Replace(vrhtml, "align=center x:publishsource=", "align=left x:publishsource=")
    ktp.Close savechanges:=False
    Kill kyt
    Set ts = Nothing
    Set fs = Nothing
    Set ktp = Nothing
End Function[/SIZE]

mustilem23 · 19 Şubat 2016

ilginiz için teşekkür ederim sayın Plint,

verdiğiniz kodları ekledim excelin içine çalışıyor
fakat command butona bastımığımda farklı kaydet diyor bende iptal diyorum ve emailin içinde istediğimiz gibi 8 sütun olarak eklenip çalışıyor

tek sorunumuz şu ilk deki farklı kaydet önceden çıkmıyordu bunu kaldırabilmemiz mümkün müdür ?

visualın içindeki kodlar bu şekildedir.

PLİNT · 19 Şubat 2016

mustilem23' Alıntı:
ilginiz için teşekkür ederim sayın Plint,
verdiğiniz kodları ekledim excelin içine çalışıyor
fakat command butona bastımığımda farklı kaydet diyor bende iptal diyorum ve emailin içinde istediğimiz gibi 8 sütun olarak eklenip çalışıyor
tek sorunumuz şu ilk deki farklı kaydet önceden çıkmıyordu bunu kaldırabilmemiz mümkün müdür ?
visualın içindeki kodlar bu şekildedir.

Merhaba
Ek dosyadaki gibi deneyin.Yukarıdaki kodlarda düzeltildi.
http://s8.dosya.tc/server2/s35b60/email.zip.html

Kod:

vrhtml = Replace(vrhtml, "align=center xublishsource=", "align=left xublishsource=")
ktp.Close savechanges:=[COLOR="Red"]False[/COLOR]'BURASI FALSE OLACAKTI
[COLOR="Red"]Kill kyt[/COLOR] 'BAŞINDAKİ TIRNAK KALKACAKTI
Set ts = Nothing
Set fs = Nothing
Set ktp = Nothing
End Function

Son isteğinize göre kodları ekledikten sonra deneme için yaptığım şekilde kalmış.
Yukarıdaki ek dosyada düzeltilmiş şekli bulunuyor.

mustilem23 · 19 Şubat 2016

elinize sağlık çok teşekkür ederim ,süper ötesi oldu

mustilem23 · 13 Ocak 2017

Sayın Plint iyi geceler ,

yapılan çalışma için ine teşekkür ederim ,ben aynı makroyu farklı bir amaç içinde kullanmak istiyorum ama bir kaç düzenlemede bulunulmasını rica edeceğim ,söyleki ;

A sutununda ki tedarikçi nosunu alıp sayfa 1 de a sutunun da arayıp karşılık gelen b c d e f g satırlarındaki email adresleri kime kısmını yapıştırmasını rica ediyorum yardımcı olabilir misiniz rica etsem ,

tedarikçilerimiz bu ara işleri epey aksatmaya başladı.

Örnek dosyam aşağıdaki gibidir.
http://s3.dosya.tc/server10/xai724/email.xls.html

PLİNT · 15 Ocak 2017

mustilem23' Alıntı:
Sayın Plint iyi geceler ,
A sutununda ki tedarikçi nosunu alıp sayfa 1 de a sutunun da arayıp karşılık gelen b c d e f g satırlarındaki email adresleri kime kısmını yapıştırmasını rica ediyorum yardımcı olabilir misiniz rica etsem ,

Merhaba
Anladığım şekle göre; "A" sütununda süzme işlemi yapılıp "A1" in altındaki
görünür tedarikçi diğer sayfada bulunup karşısındaki adresler alınacak.
Aşağıdaki kırmızı bölümleri ekleyip/değişip deneyin.

Kod:

[SIZE="2"]Sub mail()
 Dim hcr As Range
    Dim OutApp As Object
    Dim OutMail As Object
    [COLOR="Red"]Dim act, s1, s2 As Worksheet[/COLOR]
    Set hcr = Nothing
    Set act = ActiveSheet
   [COLOR="Red"] Dim n, p, ı, kime[/COLOR]
[COLOR="Red"] Set s1 = Sheets("Sayfa1")
 Set s2 = Sheets("ListeSatisSiparisiSatirlari 160")
 n = s2.Range("A2:A" & s2.Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Row
 Set r = s1.[A:A].Find(s2.Cells(n, 1), , xlValues, xlWhole)
 If Not r Is Nothing Then
 For ı = 2 To 7
 If s1.Cells(r.Row, ı) <> "" Then
 If kime <> Empty Then p = ";"
 kime = kime & p & s1.Cells(r.Row, ı)
 End If
 Next
 End If[/COLOR]
On Error Resume Next
Set hcr = act.Range("A3:O" & act.Cells(Rows.Count, "A").End(3).Row)
On Error GoTo 0
Application.EnableEvents = False
Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
     [COLOR="Red"]   .to = kime[/COLOR]
        .CC = "" 
'....
'.....diğer kodlar
'....
[/SIZE]

excelde seçili sütunları email gönderme

mustilem23

mustilem23

mustilem23

mustilem23

Mehmet Şahin

Destek Ekibi

Korhan Ayhan

Administrator

mustilem23

PLİNT

mustilem23

PLİNT

mustilem23

PLİNT

halit3

Uzman

mustilem23

PLİNT

mustilem23

PLİNT

mustilem23

mustilem23

PLİNT