Excel'den Mail Gönderme (ilgili satırdan veri çekmek)

[tirEdsOuL]

Hüseyin bey ellerinize emeğinize sağlık çok teşekkür ederim.

Önemsiz ufak bir sıkıntı var sadece, kopyalama yapılan sayfalar filtreli olarak kalıyor, kopyalama yapıldıktan sonra filtrelerin çözülmesi sağlanabilir mi?

 

[Emir Hüseyin Çoban]

. . .

Next i satırından sonra kırmızı ile belirttiğim kodları ilave edin... Sayfaları tekrar döngüye sokarak, filtreleri açıyoruz.

   [B] Next i[/B]
    
    [COLOR="Red"]For i = 1 To 3
        With Sheets(sayfalar(i))           
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
        End With
    Next i[/COLOR]
    
  [B]  Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)[/B]

. . .

 

[tirEdsOuL]

Çok teşekkürler Hüseyin bey, sorunsuz çalışmakta..

 

[tirEdsOuL]

Hüseyin bey merhaba;

Bugün makroyu toplam 58 satırlık bir dosya için çalıştırdım ama kopyalama yaptığı "mail için" sayfasına tamamını aktarmasına rağmen 56 satırı kopyalayıp maile aktardı. Kodu aşağıdaki gibi değiştirip şimdilik bir çözüm buldum ama (+3 olan kısmı +5 yaptım) kalıcı bir çözüm değil..

S1.Range("B1:H" & sonsat + [COLOR="Red"]3[/COLOR]).Copy

Ayrıca sizin verdiğiniz kodda "A1:H" idi, ben A sütununu almaması için orayı "B" sütunu olarak değiştirdim.

 

[Emir Hüseyin Çoban]

.

Yukarıdaki verilerin olduğu örneği görmek gerekir.
Değişiklik yaparken atladığınız kısımlar olabilir.

.

 

[tirEdsOuL]

sayfalarda bir değişiklik yoktur, kod aşağıdaki şekilde düzenlenmiştir.

Sub kod()
    Dim S1 As Worksheet: Set S1 = Sheets("mail için")
    Dim OutApp As Object
    Dim OutMail As Object
    sayfalar = Array("", "Otomobil", "HTA", "Kamyon")
    Dim i As Byte
    Dim sonsat As Integer
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    S1.Visible = True: S1.Select
    S1.Cells.Clear
    
    S1.Range("[COLOR="Red"]B1[/COLOR]") = "Aşağıda detayları verilen araçların alınmasını rica ederim."
    S1.Range("A2") = " "
    
    
    For i = 1 To 3
        With Sheets(sayfalar(i))
            On Error Resume Next
            
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
            
            .Range("A1").AutoFilter Field:=1, Criteria1:="2"
            .AutoFilter.Range.Copy
            sonsat = S1.Cells(Rows.Count, "A").End(3).Row + 1
            S1.Cells(sonsat, "A").PasteSpecial Paste:=x1PasteColumnWidths, Operation:=x1None, _
            SkipBlanks:=False, Transpose:=False
            S1.Paste
            Application.CutCopyMode = False
            
            If sonsat <> 3 Then
                S1.Rows(sonsat).Delete Shift:=xlUp
            End If
        End With
    Next i
    
    For i = 1 To 3
        With Sheets(sayfalar(i))
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
        End With
    Next i
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    
    
    
    S1.Range("[COLOR="Red"]B1[/COLOR]:H" & sonsat + 5).Copy
    With OutMail
        .To = "[COLOR="Red"]x@x.com.tr[/COLOR] "
        .Subject = "[COLOR="Red"]Araç Alımları Hk.[/COLOR]"
        .Display
        DoEvents
        SendKeys "^v", True
    End With
    
    S1.Visible = False
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Application.SendKeys ("{NUMLOCK}")
    
End Sub

 

[tirEdsOuL]

Hüseyin bey merhaba;

Bu konumuzdan yola çıkarak şöyle birşey yapmak istedim ama maalesef başarısız oldum.

Rapor sayfasında, 8nci satırdan başlayan bir tablo var, bu tabloda "K" sütununda kredi başlangıç tarihi, "L" sütununda ise Kredinin kapama tarihi var.
Benim yapmak istediğim ise; "L" sütunu boş olup, "K" sütunu bugünden 175 gün eşit ya da büyükse "C, D, H+J, K+179" sütunlarını mail olarak göndermek, tabi bunu excelin açılışında kontrol ettirip onayım halinde mail atmak.

Sub kod()
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
       
    Dim SS As Worksheet: Set SS = Sheets("Rapor")
    Dim xlOutlook   As Object
    Dim xlMail      As Object

    For i = 2 To SS.Cells(Rows.Count, "K").End(3).Row
        If UCase(Replace(SS.Cells(i, "K"), "i", "İ")) >= Now - 175 And UCase(Replace(SS.Cells(i, "L"), "i", "İ")) = "" Then
        metin = metin & "Sipariş No : " & SS.Cells(i, "D") & "   " & "Tipi : " & SS.Cells(i, "F") & "<br>" & _
            "Kapama Tarihi : " & SS.Cells(i, "K") + 179 & "<br>" & _
            "Banka : " & SS.Cells(i, "C") + 179 & "<br>" & _
            "Yak. Kapama Tutarı: " & Format(SS.Cells(i, "H") + SS.Cells(i, "J"), "#,##0.00") & " TL" & "<br>-<br>"
        aciklama = "Aşağıda bilgileri verilen araçların kapama günleri yaklaşmaktadır."
        baslik = Left("Yaklaşan Araç Kapamaları hk.", 255)
    End If
    Next i
    
   
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)
Set fso = CreateObject("Scripting.FileSystemObject")
yol = "C:\Users\ebulut\AppData\Roaming\Microsoft\Signatures\İmza.htm"
Set imza = fso.OpenTextFile(yol, 1)
    
    With xlMail
        .To = "xxx@xxx.com.tr"
.CC = "xxx@xxx.com.tr"
.Subject = baslik 'Left("2.EL Takas Ödemeleri" & plaka, 255)
.HTMLBody = "<font face=calibri>" & aciklama & "<BR><BR>" & _
    metin & "</font>" & "<BR><BR>" & imza.readall
        .Save
        .Display
        '.Send
    End With
Set xlMail = Nothing
Set xlOutlook = Nothing
metin = Empty
    
    With Application
.EnableEvents = True
.ScreenUpdating = True
    End With
End Sub