• DİKKAT

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

Exceldeki tablodan ilgili firmalara mail atma

  • Konbuyu başlatan Konbuyu başlatan vuvu1
  • Başlangıç tarihi Başlangıç tarihi
V

vuvu1

Katılım
15 Temmuz 2011
Mesajlar
16
Excel Vers. ve Dili
2007
Merhaba,
ekteki exceldeki tabloda yer alan bilgileri firma koduna göre outlooktan mail atılmasını istiyorum,
yaklaşık 1000 satır bilgi oluyor ve her gün 50 firmaya ekteki örneklerde oluşturduğum gibi mail atıyorum 1-2 saatim gidiyor, yardımlarınızı rica ederim,
Saygılarımla,
 
Son düzenleme:
Dosyanızla ilgileniyorum. Siz de Outlook uygulamasında aşağıdaki ayarı yapın. (Toplu mail göndereceğiniz zaman)

attachment.php
 

Ekli dosyalar

  • Adsız.jpg
    Adsız.jpg
    67.1 KB · Görüntüleme: 154
Dosya ekte...

Kod: 
Sub Mail_Gonder()
    Set oApp = CreateObject("Outlook.Application")
    
    s1 = UserForm1.TextBox1.Text [COLOR=DarkGreen]' Kayıtlı şablonun tutulduğu yer[/COLOR]
    
    For i = 2 To Sayfa2.[a10000].End(3).Row
    
        s2 = s1
        s2 = Replace(s2, "@mailto@", Sayfa2.Cells(i, "m").Text)
        s2 = Replace(s2, "@mailcc@", Sayfa2.Cells(i, "n").Text)
        s2 = Replace(s2, "@sipno@", Sayfa2.Cells(i, "a").Text)
        s2 = Replace(s2, "@testar@", Sayfa2.Cells(i, "b").Text)
        s2 = Replace(s2, "@siptar@", Sayfa2.Cells(i, "c").Text)
        s2 = Replace(s2, "@firmakod@", Sayfa2.Cells(i, "d").Text)
        s2 = Replace(s2, "@firmaadi@", Sayfa2.Cells(i, "e").Text)
        s2 = Replace(s2, "@urunno@", Sayfa2.Cells(i, "f").Text)
        s2 = Replace(s2, "@urunadi@", Sayfa2.Cells(i, "g").Text)
        s2 = Replace(s2, "@durum@", Sayfa2.Cells(i, "h").Text)
        s2 = Replace(s2, "@sipmiktar@", Sayfa2.Cells(i, "I").Text)
        s2 = Replace(s2, "@koliici@", Sayfa2.Cells(i, "j").Text)
        s2 = Replace(s2, "@koli@", Sayfa2.Cells(i, "k").Text)
        
        Set msg = oApp.CreateItem(0) [COLOR=DarkGreen]' Yeni Mail=0[/COLOR]
    
        With msg
            [COLOR=DarkGreen]'.DeferredDeliveryTime = CDate("01.12.2013") ' Bu tarihten önce teslim etme
            '.ExpiryTime = CDate("10.12.2013")           ' Son geçerlilik
            '.Importance = 1                             ' ÖNEM: 0=Düşük, 1=Normal, 2=Yüksek
            '.Sensitivity = 0                            ' DUYARLILIK: 0=Normal, 1=Kişisel, 2=Özel, 3=Gizli
            '.OriginatorDeliveryReportRequested = True   ' Teslim bilgisi iste
            '.ReadReceiptRequested = True                ' Okundu bilgisi iste[/COLOR]
            
            ReDim cc(1 To 1) As String
            
            For j = 13 To 21
                If Trim(Sayfa2.Cells(i, j).Text) <> "" Then
                    ccCount = ccCount + 1
                    ReDim Preserve cc(1 To ccCount) As String
                    cc(ccCount) = Sayfa2.Cells(i, j).Text
                End If
            Next
            
            .To = Sayfa2.Cells(i, "m").Text
            .cc = Join(cc, ";")
            .Subject = "KONU ADINI YAZINIZ !!!"[COLOR=DarkGreen] ' <<<<< Buradaki başlığı değiştirin.[/COLOR]
            .HTMLBody = s2
            .Send
        End With
        
    Next
End Sub
 

Ekli dosyalar

Zeki bey, merhaba,
süpersiniz, gayet güzel olmuş, teşekkürler, her gün önceki maili ara-bul, reply all yap, tabloyu yapıştır, vs ile 2 saat harcadığım mail atma işinde tüm maillerin bu kadar çabuk giden kutusuna düşmesini hiç beklemiyordum, ama baktım hepsi gidiyor bile :)
sadece 1-2 ufak ayar kısmı kalmış, ekte not kısmında resim çektim gönderdim, mail içinde ayrıca to: ve cc yazmaya gerek yok, zaten o kişilere gidiyor, birde imza yazmasına gerek yok, zaten imza altta olacak, ben bunu kaldıracaktım ama userforma girdim baya uzun bir yazı çıktı, çok uzun bir text yazısı, nasıl yazdınız o kadar yazıyı walla bravo. mail içeriği anlaşılan kolay kolay değişecek bir şey değil değilmi?
mail konusunda bir formul yapabilirmiyiz?
birde ekte 9 satır var giden kutusunda 9 mail olmuş, oysa firma kodu aynı olanlarda 1 mail olmalıydı, mesela firma kodu 1173den 4 satır var, 4 mailde tek satır yerine 1 mail 4 satırıda alt alta göstermeliydi, ben tablonun sonuna mail no diye bir şey ekledim, belki buna göre mail attırabilirsiniz.
son olarak maillerin direk giden kutusuna değilde taslaklara düşmesini yada ekrana hazır olarak gelmesini sağlayabilirmisiniz başka bir buton ile, son 1 kez kontrol edip göndermekte fayda var diye düşündüm de.
Tekrar teşekkürler,
saygılar,
 
Son düzenleme:
Merhaba,

HTML elle yazılmıyor elbette. :) İçeriğine @anahtarkelime@ yazıp ihtiyaca göre değiştirdim.

Mailler taslak klasörüne düşürülebilir. Yarına artık....
 
Zeki bey selamlar, 1 firmaya 4-5 satır olunca 4-5 ayrı mail atmak yerine 1 mail atma işini de bugün mü bakacaksınız? birde mail konusunda son gönderdiğim dosyadaki gibi formul yapabilirmiyiz? yardımlarınızı rica ederim.. saygılar..
 
Sanırım bu kez oldu.

Aynı firma koduna ait satırlar toparlandı ve iletiler gönderilmeye hazır olarak "taslak" klasöründe bekliyor.

Kod: 
Sub Mail_Gonder()
    Dim col As New Collection
    
    If Sayfa2.AutoFilterMode Then[COLOR=DarkGreen] ' Varsa Filitre modundan çık[/COLOR]
        Sayfa2.AutoFilterMode = False
    End If
    
    son = Sayfa2.[a10000].End(3).Row[COLOR=DarkGreen] ' Tablonun son satırnı bul[/COLOR]
    
    Set rng = Sayfa2.Range("d2:d" & son)[COLOR=DarkGreen] ' Tabloyu değişkene ata[/COLOR]
  
    For i = 1 To son - 1[COLOR=DarkGreen] ' Tekil firma kodlarını al[/COLOR]
        If Not Exists(col, rng.Cells(i)) Then col.Add rng.Cells(i), CStr(rng.Cells(i))
    Next
    
    Application.ScreenUpdating = False[COLOR=DarkGreen] ' Ekran değişimlerini gizle[/COLOR]
    
    For i = 1 To col.Count[COLOR=DarkGreen] ' .htm dosyalarını hazırla[/COLOR]
    
        Set wb = Workbooks.Add
        
        Set sh = wb.Sheets(1)
        
        Sayfa2.Range("a1:k" & son).AutoFilter Field:=4, Criteria1:=CStr(col(i))
        
        Sayfa2.Range("a1:k" & son).SpecialCells(xlCellTypeVisible).Copy
        
        sh.[a1].PasteSpecial 8    [COLOR=DarkGreen] ' Sütun genişliklerini[/COLOR]
        sh.[a1].PasteSpecial -4122[COLOR=DarkGreen] ' Biçimleri[/COLOR]
        sh.[a1].PasteSpecial -4163 [COLOR=DarkGreen]' Değerleri[/COLOR]
        
        Application.CutCopyMode = False
        
        [COLOR=DarkGreen]' C:\  altına htm dosyaları oluştur (sonra silinecek)[/COLOR]
        With wb.PublishObjects.Add(SourceType:=xlSourceRange, _
             Filename:="C:\" & col(i) & ".htm", Sheet:=wb.Sheets(1).Name, _
             Source:=wb.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
        
        wb.Close False
        
        Open "C:\" & col(i) & ".htm" For Input As #1: html = Input(LOF(1), #1): Close #1
        
        html = Replace(html, "align=center x:publishsource=", "align=left x:publishsource=")
        
        Open "C:\" & col(i) & ".htm" For Output As #1: Print #1, html: Close #1
        
    Next
    
    Sayfa2.AutoFilterMode = False[COLOR=DarkGreen] ' Filitre modunu bitir[/COLOR]
    
    Set oApp = CreateObject("Outlook.Application")
    
    For i = 1 To col.Count
    
        Set msg = oApp.CreateItem(0)
        
       [COLOR=DarkGreen] ' Mail adreslerini toparlamak üzere ilgili firma kodu satırnı bul[/COLOR]
        Set f = Sayfa2.Range("d1:d" & son).Find(CStr(col(i)), LookAt:=xlWhole)
        
        With msg
            
            ReDim cc(1 To 1) As String
            
            For j = 14 To 21 [COLOR=DarkGreen]' CC adreslerini birleştir[/COLOR]
                If Trim(Sayfa2.Cells(f.Row, j).Text) <> "" Then
                    ccCount = ccCount + 1
                    ReDim Preserve cc(1 To ccCount) As String
                    cc(ccCount) = Sayfa2.Cells(f.Row, j).Text
                End If
            Next
            
            .To = Sayfa2.Cells(f.Row, "m").Text              [COLOR=DarkGreen] ' Kime[/COLOR]
            .cc = Join(cc, ";")                              [COLOR=DarkGreen] ' Bilgi[/COLOR]
            .Subject = "Depo Siparişi (" & CStr(col(i)) & ")" [COLOR=DarkGreen]' Konu[/COLOR]
            
            Open "C:\" & col(i) & ".htm" For Input As #1: html = Input(LOF(1), #1): Close #1
            
           [COLOR=DarkGreen] ' Metni (merhaba, siparişiniz... saygılarımla ... gibi) ilave ediyoruz.[/COLOR]
            html = Split(html, "<body>")(0) & "<body>" & UserForm1.TextBox1 & Split(html, "<body>")(1)
            
            .HTMLBody = html
            
            .Save[COLOR=DarkGreen] ' Outlook iletilerini "taslak" a kaydet[/COLOR]
        End With
        
        Kill "C:\" & col(i) & ".htm"[COLOR=DarkGreen] ' C:\ altındaki htm dosyaları sil[/COLOR]
        
    Next
    
    Application.ScreenUpdating = True[COLOR=DarkGreen] ' Ekran değişimlerini göster[/COLOR]
    
    MsgBox "İşlem tamamlandı", vbInformation, "::.. Zeki Gürsoy - www.excel.web.tr ..::  "
End Sub

Private Function Exists(arr As Collection, item) As Boolean
    [COLOR=DarkGreen]' Collection nesnesine tekil isim olması için kullanıyoruz.[/COLOR]
    For Each v In arr
        If v = item Then
            Exists = True
            Exit For
        End If
    Next
End Function
 

Ekli dosyalar

Zeki bey merhaba,
çok ilgilisiniz ve tek kelime ile süpersiniz.. açıklamalar gayet güzel ve öğretici..
çok teşekkürler, saygılar.
 
Zeki bey, merhaba,
kullanmakta olduğum imza oluşan maillerin altında olmuyor, taslaktaki maillere ekleyip gönderebiliyorum, hazır kullandığım kayıtlı imzanında mailin altında olması için ne yapabilirim, yardımlarınızı rica ederim, saygılar..
 
Merhaba,

HTML kodu imzayı ezdi geçti galiba. Galiba onu da html içine eklememiz gerekecek.



İmzanızı (font, renk gibi özelliğiyle) adresime gönderin, onu da html koduna eklemeye çalışalım.
 
Merhaba, Zeki bey, mail attım, yardımlarınız için şimdiden teşekkürler..
 
Dosya son şeklini almış durumda. İmza olarak Outlook taki imzanız konacak, ancak imzada resim olmasın.
Resim ekleyecekseniz "L1" hücresinde göreceğiniz imza isimleri ile aynı isimde C:\ altına jpg resim koyun.

Kolay gelsin...

Kod: 
Sub Mail_Gonder()
    Dim col As New Collection
    
    If Sayfa2.AutoFilterMode Then[COLOR=DarkGreen] ' Varsa Filitre modundan çık[/COLOR]
        Sayfa2.AutoFilterMode = False
    End If
    
    son = Sayfa2.[a10000].End(3).Row[COLOR=DarkGreen] ' Tablonun son satırnı bul[/COLOR]
    
    Set rng = Sayfa2.Range("d2:d" & son) [COLOR=DarkGreen]' Tabloyu değişkene ata[/COLOR]
  
    For i = 1 To son - 1[COLOR=DarkGreen] ' Tekil firma kodlarını al[/COLOR]
        If Not Exists(col, rng.Cells(i)) Then col.Add rng.Cells(i), CStr(rng.Cells(i))
    Next
    
    Application.ScreenUpdating = False[COLOR=DarkGreen] ' Ekran değişimlerini gizle[/COLOR]
    
    For i = 1 To col.Count[COLOR=DarkGreen] ' .htm dosyalarını hazırla[/COLOR]
    
        Set wb = Workbooks.Add
        
        Set sh = wb.Sheets(1)
        
        Sayfa2.Range("a1:k" & son).AutoFilter Field:=4, Criteria1:=CStr(col(i))
        
        Sayfa2.Range("a1:k" & son).SpecialCells(xlCellTypeVisible).Copy
        
        sh.[a1].PasteSpecial 8   [COLOR=DarkGreen]  ' Sütun genişliklerini[/COLOR]
        sh.[a1].PasteSpecial -4122[COLOR=DarkGreen] ' Biçimleri[/COLOR]
        sh.[a1].PasteSpecial -4163[COLOR=DarkGreen] ' Değerleri[/COLOR]
        
        Application.CutCopyMode = False
        
       [COLOR=DarkGreen] ' C:\  altına htm dosyaları oluştur (sonra silinecek)[/COLOR]
        With wb.PublishObjects.Add(SourceType:=xlSourceRange, _
             Filename:="C:\" & col(i) & ".htm", Sheet:=wb.Sheets(1).Name, _
             Source:=wb.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
        
        wb.Close False
        
        Open "C:\" & col(i) & ".htm" For Input As #1: html = Input(LOF(1), #1): Close #1
        
        html = Replace(html, "align=center x:publishsource=", "align=left x:publishsource=")
        
        Open "C:\" & col(i) & ".htm" For Output As #1: Print #1, html: Close #1
        
    Next
    
    Sayfa2.AutoFilterMode = False [COLOR=DarkGreen]' Filitre modunu bitir[/COLOR]
    
    Set oApp = CreateObject("Outlook.Application")
    
    For i = 1 To col.Count
    
        Set msg = oApp.CreateItem(0)
        
       [COLOR=DarkGreen] ' Mail adreslerini toparlamak üzere ilgili firma kodu satırnı bul[/COLOR]
        Set f = Sayfa2.Range("d1:d" & son).Find(CStr(col(i)), LookAt:=xlWhole)
        
        With msg
            
            ReDim cc(1 To 1) As String
            
            For j = 14 To 21[COLOR=DarkGreen] ' CC adreslerini birleştir[/COLOR]
                If Trim(Sayfa2.Cells(f.Row, j).Text) <> "" Then
                    ccCount = ccCount + 1
                    ReDim Preserve cc(1 To ccCount) As String
                    cc(ccCount) = Sayfa2.Cells(f.Row, j).Text
                End If
            Next
            
            .To = Sayfa2.Cells(f.Row, "m").Text             [COLOR=DarkGreen]  ' Kime[/COLOR]
            .cc = Join(cc, ";")                             [COLOR=DarkGreen]  ' Bilgi[/COLOR]
            .Subject = "Depo Siparişi (" & CStr(col(i)) & ")"[COLOR=DarkGreen] ' Konu[/COLOR]
            
           [COLOR=DarkGreen] ' Varsa İmza altına gelecek resim ataçlanacak.[/COLOR]
            If Dir("C:\" & Sayfa2.[L1] & ".jpg") <> "" Then
                .Attachments.Add "C:\" & Sayfa2.[L1] & ".jpg"
            End If
            
            Open "C:\" & col(i) & ".htm" For Input As #1: html = Input(LOF(1), #1): Close #1
            
           [COLOR=DarkGreen] ' Metni (merhaba, siparişiniz... saygılarımla ... gibi) ilave ediyoruz.[/COLOR]
            html = Split(html, "<body>")(0) & "<body>" & UserForm1.TextBox1 & Split(html, "<body>")(1)
            
          [COLOR=DarkGreen]  ' İmzayı al[/COLOR]
            If Dir(Environ("APPDATA") & "\Microsoft\Signatures\" & Sayfa2.[L1] & ".htm", vbHidden) <> "" Then
                Open Environ("APPDATA") & "\Microsoft\Signatures\" & Sayfa2.[L1] & ".htm" For Input As #1: imza = Input(LOF(1), #1): Close #1
                html = html & "<br><br>" & imza
            End If
            
           [COLOR=DarkGreen] ' İmza olarak kullanılacak resim varsa...
            ' Resim kullanılacaksa, C:\ dizininde imza adı ile aynı isimde .jpg uzantılı olacak.
            ' Ör: vv isimli imza için C:\vv.jpg dosyası olmalı.[/COLOR]
          [COLOR=DarkGreen]  ' İmza olarak yalnız resim kullanılacaksa, Outlook taki kayıtlı imzayı boş olarak kaydedin.[/COLOR]
            If Dir("C:\" & Sayfa2.[L1] & ".jpg") <> "" Then
                html = html & "<br><html><img src='cid:" & Sayfa2.[L1] & ".jpg" & "' height=480 width=360></html>"
            End If
            
            .HTMLBody = html
            .Save [COLOR=DarkGreen] ' Outlook iletilerini "taslak" a kaydet NOT: Taslak maillerde resim görülmez. Problem yok; karşıda resimli olacak.[/COLOR]
            [COLOR=DarkGreen]'.Send ' Üstte kaydettik. Aynı zamanda göndermek istersek bu satırı aktifleştirin.[/COLOR]
        End With
        
        Kill "C:\" & col(i) & ".htm"
        
    Next
    
    Application.ScreenUpdating = True[COLOR=DarkGreen] ' Ekran değişimlerini göster[/COLOR]
    
    MsgBox "İşlem tamamlandı", vbInformation, "::.. Zeki Gürsoy - www.excel.web.tr ..::  "
End Sub

Private Function Exists(arr As Collection, item) As Boolean
    [COLOR=DarkGreen]' Collection nesnesine tekil isim olması için kullanıyoruz.[/COLOR]
    For Each v In arr
        If v = item Then
            Exists = True
            Exit For
        End If
    Next
End Function
 

Ekli dosyalar

Zeki bey merhaba, teşekkürler imza ekleniyor, yalnız resim aşağıda çıkıyor ebatlarıda büyük baya, size mail attım, nasıl düzeltebiliriz, yardımlarınız rica. saygılar.
 
Kod içinde ebatları bulun ve aşağıdaki gibi değiştirin:

Kod: 
height=87 width=94
 
Zeki bey ebatlar ok, güzel oldu, sadece resim ile imza yazısı arası biraz açık kaldı, 2 satır gibi bunu nereden azaltabilirim acaba <br> lerden birini sildim olmadı. birde jpeg resim dosya eklenmiş olarak karşı tarafa gidiyor, bunu iptal edebilirmiyiz? ilginiz için teşekkürler.
 
çok güzel bir çalışma teşekkürler fakat e mail tanımlaması başka sheet den vlookup ile tanımlamak mümkünmü. örneğin Sheet3 de (A1 de şirket ismi) (A2 de To:) (A3 de CC) gibi. bunu eklemeniz mümkün mü?
 
AYNI SİSEMİ GÖNDERMİŞ OLDUGUM EXCELL İÇİN UYARLAYABİLİRMİSİNİZ YARDIMCI OLURSANIZ ÇOK SEVİNRİM...
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst