Excelden e-mail nasıl yollarım

[search77]

Haluk bey ben derdimi anlatamıyorum galiba aslında çok basit biliyorum bunu yapabileceğinizi, size ulaşabilceğim bir tel var mı? Derdimi canlı anlatsam

 

[Haluk]

Yani artık daha nasıl yardımcı olabilirim bilmiyorum.....

En son yolladığım sizin istediğiniz gibi olması lazım.

"To" kısmında süzme yaptığınızda, gidecek e-mail' in "To" kısmında, süzülen e-mail adresi var. Mesaj gövdesinde ilgili tüm kişi ve adresleri var, "CC" kısmında da tüm CC' ler var. Bunların hepsi de tek bir mail halinde.

Bunun ötesinde daha ne var, bir türlü anlamadım.

Bana özel mesajla telefon numaranızı yollayabilirsiniz.

.

 

[search77]

Haluk bey,

Dosya formatını ekliyorum, mail içine gelecek tablo A hücresinden başlıyor AC hücresinde bitiyor. Yani TO kısmındaki (AD hücresinde) filitre yaptığımda A-AC arasında hangi bilgiler var ise tümü tablo şeklinde mail içinde olsun.

Birde datam 65.000 satır olabilir, yani filitre değil toplam data, bu data içinde filitre yapabilirim, bu sorun olur mu?

Sizi çok yorucam farkındayım, ama bu macro benim için çok önemli, desteğiniz ve emeğiniz için şimdiden çok çok teşekkür ediyorum.

Saygı ve sevgilerimle.

 

[Haluk]

Merhaba;

Aşağıdaki kodu bir deneyin, sorun çıkarsa bakalım....

Saygı bizden,

.

Sub Test()
    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim BodyText1 As Object, BodyText2, BodyText3 As Object
    Dim MyRange As Range
    Dim TempFile1 As String, TempFile2, TempFile3 As String
    Dim strHTMLBody As String, strCC As String
    Dim lRow As Long, NoA As Long
    Dim aRng As Range
    
    NoA = Cells(65536, 1).End(xlUp).Row
    TempFile1 = "C:\TempHTML1.htm"
    TempFile2 = "C:\TempHTML2.htm"
    TempFile3 = "C:\TempHTML3.htm"
    
    Set FSO = CreateObject("Scripting.FilesystemObject")
    
    For Each aRng In Range("A2:A" & NoA).Cells.SpecialCells(xlCellTypeVisible)
        On Error Resume Next
        If aRng <> Empty Then
            lRow = aRng.Row
            
            Set MyRange = ActiveSheet.Range("A" & lRow & ":AC" & lRow)
            
            If MyRange Is Nothing Then Exit Sub
            ActiveWorkbook.PublishObjects.Add _
            (4, TempFile1, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
            
            Set BodyText1 = FSO.OpenTextFile(TempFile1, 1)
            
            strHTMLBody = strHTMLBody & BodyText1.ReadAll
            
            strCC = strCC & ActiveSheet.Range("AE" & lRow) & ";" & ActiveSheet.Range("AF" & lRow) & ";"
            
            Kill TempFile1
        End If
    Next
    
    Set MyRange = ActiveSheet.Range("AH" & lRow)
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile2, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    
    Set MyRange = ActiveSheet.Range("A1:AC1")
    ActiveWorkbook.PublishObjects.Add _
    (4, TempFile3, MyRange.Parent.Name, MyRange.Address, 0, "", "").Publish True
    
    Set BodyText2 = FSO.OpenTextFile(TempFile2, 1)
    Set BodyText3 = FSO.OpenTextFile(TempFile3, 1)
            
    strHTMLBody = BodyText2.ReadAll & BodyText3.ReadAll & strHTMLBody
    strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", , , vbTextCompare)
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
    With OutlookMsg
        .HTMLBody = strHTMLBody
        .Subject = ActiveSheet.Range("AG" & lRow)
        .To = ActiveSheet.Range("AD" & lRow)
        .CC = strCC
        .Send
'        .Display
    End With
    
    Kill TempFile2
    Kill TempFile3
            
    Set BodyText3 = Nothing
    Set BodyText2 = Nothing
    Set BodyText1 = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set MyRange = Nothing
    Set FSO = Nothing
End Sub

 

[search77]

Haluk bey bence bu bomba elinize sağlık süper olmuş, ilginiz ve desteğiniz için ne kadar teşekkür etsem azdır, çok uğraştınız, çok sağolun,

Mesleğim ile ilgili bilgi ve yardım için beni herzaman arayabilirsiniz hiç olmazsa bende öyle yardımcı olmaya çalışıyım.

Saygı ve sevgilerimle.

Bülent