mail adresine tıklayınca o firmanın ekstresini mail ile yollamak

Katılım
20 Aralık 2013
Mesajlar
195
Excel Vers. ve Dili
Microsoft Office Standart 2013 - Microsoft Windows 10 Enterprise
merhabalar arkadaşlar

ekteki dosyada bir liste var istediğim mail adresine tıklayınca o firmanın hareketlerini süzüp, ekstresini çıkardıktan sonra outlooka yeni mail oluşturmak

mümkün müdür?

http://dosya.co/cqx4r33d5sav/01-2016.rar.html
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Ekte bulunan dosyayı deneyiniz. (Maili göndermek için kodlar içindeki ('Send) başındaki " ' " tırnağı kaldırın)
http://s4.dosya.tc/server/0s147y/gkhn.zip.html

Boş outlook sayfası açılmaması için; (örnek dosyadaki gibi) "L" sütunundaki mail adreslerinin köprülerini kaldırın.
Bunun içinde aşağıdaki makroyu bir kere çalıştırınız.
Kod:
sub kaldır()
m = sheets("TOPLAM").Cells(Rows.Count, 1).End(3).Row
sheets("TOPLAM").Range("L3:L" & m).Hyperlinks.Delete
end sub
Dosyada ki kodlar
Sayfada:
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
m = Cells(Rows.Count, 1).End(3).Row

If Intersect(Target, Range("L3:L" & m)) Is Nothing Then Exit Sub
Application.EnableEvents = False
formul1 = Cells(m + 1, "F").FormulaR1C1
formul2 = Cells(m + 1, "J").FormulaR1C1
Dim hcr As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set hcr = Nothing
On Error Resume Next
Range("D3:D" & m).ColumnDifferences(Comparison:=Range("D" & Target.Row)).EntireRow.Hidden = True
Range("J" & m + 1) = Application.Sum(Range("J3:J" & m).SpecialCells(xlCellTypeVisible).Cells)
Range("F" & m + 1) = Application.Sum(Range("F3:F" & m).SpecialCells(xlCellTypeVisible).Cells)
Set hcr = Range([COLOR="Red"]"A1:K"[/COLOR] & m + 1).SpecialCells(xlCellTypeVisible).Cells
On Error GoTo 0
Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
       ' .SentOnBehalfOfName = "GKHN@domain.com" 'KİMDEN
        .To = Range("L" & Target.Row).Value
        .CC = ""
        .BCC = ""
        .Subject = Range("A1").Value
        .BodyFormat = 2
        .HTMLBody = vrhtml(hcr)
        .Save
        '.........................
        '.Send  '..........GÖNDERMEK İÇİN
        '............
        .Display
    End With
    On Error GoTo 0
Application.ScreenUpdating = True
    Set OutMail = Nothing
    Set OutApp = Nothing
Cells.EntireRow.Hidden = False
Application.EnableEvents = True
Cells(m + 1, "F").FormulaR1C1 = formul1
Cells(m + 1, "J").FormulaR1C1 = formul2
End Sub
Modülde:
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
    kyt = ThisWorkbook.Path & "\" & "yeni" & ".htm"
    hcr.Copy
Set bu = ThisWorkbook
Set ktp = Workbooks.Add(1)
    With ktp.Sheets(1)

        .Cells(1, 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 12
ktp.Sheets(1).Columns(n).ColumnWidth = bu.Sheets(1).Columns(n).ColumnWidth
Next
    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
 
Son düzenleme:
Katılım
20 Aralık 2013
Mesajlar
195
Excel Vers. ve Dili
Microsoft Office Standart 2013 - Microsoft Windows 10 Enterprise
hocam eline sağlık çok teşekkür ederim. yaptığın örnek dosya her ay değişiyor malum. formatı bozmadan kopyalsam kodlar yine çalışır değil mi?

bir de outlook taki konuya a1 deki başlığı yazdırıp maili otomatik gönderebilir miyiz? excel dışına çıkıyor ama merak ettim acaba olabilir mi?
 
Son düzenleme:
Katılım
20 Aralık 2013
Mesajlar
195
Excel Vers. ve Dili
Microsoft Office Standart 2013 - Microsoft Windows 10 Enterprise
göndermek ile ilgi yazdığın not galiba otomatik göndermeyi sağlıyor. fakat mail konusu yazılması lazım
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Yukarıda dosya ve kodlar değişti, deneyin.
Kodları kullanacağınız dosya sütunları aynı olduktan sonra sorun olmaz, Kodlar "L" sütunu seçildiğinde ve seçilen hücredeki adrese göre çalışır, "A1" hücresi konu olarak maile eklenecek
eğer mesajda bu hücrenin/1.satırın görünmemesini isterseniz yukarıdaki; kırmızı bölümde bulunan "A1" i "A2" olarak değiştirin.
 
Son düzenleme:
Katılım
20 Aralık 2013
Mesajlar
195
Excel Vers. ve Dili
Microsoft Office Standart 2013 - Microsoft Windows 10 Enterprise
Yukarıda dosya ve kodlar değişti, deneyin.
Kodları kullanacağınız dosya sütunları aynı olduktan sonra sorun olmaz, Kodlar "L" sütunu seçildiğinde ve seçilen hücredeki adrese göre çalışır, "A1" hücresi konu olarak maile eklenecek
eğer mesajda bu hücrenin/1.satırın görünmemesini isterseniz yukarıdaki; kırmızı bölümde bulunan "A1" i "A2" olarak değiştirin.
yok mailde de görünebilir problem yok. biraz deneme yapmalıyım. aklıma şu geldi acaba yadımcı bir sayfa oluştursam sayfada sadece cari kod ve mail adresi olsa iki sütun. ekstre cari koda tıklasam yardımcı sayfadan mail adresini çekse nasıl olur sence. belki iki mail adresi var müşterinin?
 
Katılım
9 Mayıs 2007
Mesajlar
218
Excel Vers. ve Dili
365 TR
Örnek Dosya Silinmiş ama Bende bu çalışmaya yakın bir şey yapmak istiyorum firmalara toplu liste gönderme (Excel) konusunda yardımcı olabilirmisiniz. Teşekkürler.
 

Ekli dosyalar

Üst