• DİKKAT

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

Makro ile Mail gönderme

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Merhaba,

Her aya ait birden fazla tablom bulunmakta. Tüm tabloları tek tek mail gönderiyorum. Her aya ait tüm tabloları tek makro ile hepsini mail göndermek istiyorum.
Burada ki kod çoğaltılabilir mi ? Sheets("Aylık").Select Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


Tablolar için kullandığım kod :

Kod: 
Sub AylıkUretimRaporuOcak()

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
 
    
  Title = Range("B7")
  Kime = Range("C2")
  Bilgi = Range("C3")
  Gizli = Range("C4")
  Mesaj = Range("C5")
                    
'  PdfFile = ActiveWorkbook.FullName
'  i = InStrRev(PdfFile, ".")
'  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "" & [B7] & ".pdf"

Sheets("Aylık").Select
Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    '"....," & vbLf & vbLf _
     '     & " ....." & vbLf & vbLf _
      '    & "...." & vbLf _
       '   & [C81] & vbLf _
        '  & [C83] & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, " "
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, " "
    End If
    On Error GoTo 0
  
  End With

  Kill PdfFile

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing



End Sub

Yardımlarınız için teşekkür ederim.
 
Merhaba
Birden fazla sayfayı; tek "pdf" dosyası olarak kaydedip göndermek istiyorsanız;
(Kodlardaki sayfa adlarını düzenlersiniz)
Kod: 
ThisWorkbook.Sheets(Array("Aylık", "Aylık2", "Aylık3")).Select

Sheets("Aylık").Activate
ActiveSheet.Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Aylık").Select
 
PLİNT' Alıntı:
Merhaba
Birden fazla sayfayı; tek "pdf" dosyası olarak kaydedip göndermek istiyorsanız;
(Kodlardaki sayfa adlarını düzenlersiniz)
Kod: 
ThisWorkbook.Sheets(Array("Aylık", "Aylık2", "Aylık3")).Select

Sheets("Aylık").Activate
ActiveSheet.Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Aylık").Select
Genişletmek için tıkla ...

Merhaba Hocam,

Dediğiniz gibi yaptım ancak tek bir raporu gönderiyor.
Kod: 
Sub raporOcak()

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  Title = Range("B7")
  Kime = Range("C2")
  Bilgi = Range("C3")
  Gizli = Range("C4")
  Mesaj = Range("C5")
                    
'  PdfFile = ActiveWorkbook.FullName
'  i = InStrRev(PdfFile, ".")
'  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "" & [B7] & ".pdf"

    'ActiveSheet.Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

ThisWorkbook.Sheets(Array("Aylık", "Üretim Veri Analizi", "Ürün ve Marka Bazında")).Select


Sheets("Aylık").Activate
ActiveSheet.Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Aylık").Select

Sheets("Üretim Veri Analizi").Activate
ActiveSheet.Range("$B$7:$R$99").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Üretim Veri Analizi").Select

Sheets("Ürün ve Marka Bazında").Activate
ActiveSheet.Range("$B$7:$X$78").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Ürün ve Marka Bazında").Select



  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    '"....," & vbLf & vbLf _
     '     & " ....." & vbLf & vbLf _
      '    & "...." & vbLf _
       '   & [C81] & vbLf _
        '  & [C83] & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"
    End If
    On Error GoTo 0
  
  End With

  Kill PdfFile

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing


    
      MsgBox " Dosya Kaydedildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"



End Sub
 
Plint Hocam,

Şu şekilde yaptım, oldu ancak PDF dosya adına her tablonun kendi adını almasını yapamadım.


Örnek Aylık sayfasında B7 hücrede bulunan tablo ismini PDF dosya adı olarak yapamadım.

Sheets("Aylık").Activate PdfFile = PdfFile & "" & [B7] & ".pdf" ActiveSheet.Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False Sheets("Aylık").Select




Tek makroda şu şekilde yaptım.

Kod: 
Sub raporOcak()

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  Title = Range("B7")
  Kime = Range("C2")
  Bilgi = Range("C3")
  Gizli = Range("C4")
  Mesaj = Range("C5")


ThisWorkbook.Sheets(Array("Aylık", "Üretim Veri Analizi", "Ürün ve Marka Bazında")).Select
                    

Sheets("Aylık").Activate
PdfFile = PdfFile & "" & [B7] & ".pdf"
ActiveSheet.Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Aylık").Select

On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    '"....," & vbLf & vbLf _
     '     & " ....." & vbLf & vbLf _
      '    & "...." & vbLf _
       '   & [C81] & vbLf _
        '  & [C83] & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"
    End If
    On Error GoTo 0
  
  End With



Sheets("Üretim Veri Analizi").Select
PdfFile = PdfFile & "" & [B7] & ".pdf"
Sheets("Üretim Veri Analizi").Activate
ActiveSheet.Range("$B$7:$R$99").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Üretim Veri Analizi").Select


On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    '"....," & vbLf & vbLf _
     '     & " ....." & vbLf & vbLf _
      '    & "...." & vbLf _
       '   & [C81] & vbLf _
        '  & [C83] & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"
    End If
    On Error GoTo 0
  
  End With


Sheets("Ürün ve Marka Bazında").Select
PdfFile = PdfFile & "" & [B7] & ".pdf"
Sheets("Ürün ve Marka Bazında").Activate
ActiveSheet.Range("$B$7:$X$78").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Ürün ve Marka Bazında").Select



  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    '"....," & vbLf & vbLf _
     '     & " ....." & vbLf & vbLf _
      '    & "...." & vbLf _
       '   & [C81] & vbLf _
        '  & [C83] & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, " "
    End If
    On Error GoTo 0
  
  End With

  Kill PdfFile

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing


    
      MsgBox " Dosya Kaydedildi... İşleminiz tamamlanmıştır..! ", vbInformation, " "



End Sub
 
Merhaba
Siz üç sayfayı tek pdf dosyası yapıp adlandırmak istiyorsunuz değilmi?
PdfFile = sheets("aylık").[b7]
veya
PdfFile = sheets("aylık").[b7] & " " & sheets("Üretim Veri Analizi").[B7] & " " & sheets("Ürün ve Marka Bazında").[b7]
 
Hocam,

3 tablo ayrı ayrı isimlerde, her tabloyu kendi ismi ile pdf yapmak ve olabiliyorsa tek bir mailde göndermek istiyorum. Bu şekilde her tabloyu ayrı ayrı mail atıyor.

Yardımlarınız için teşekkür ederim.
 
Hocam,

Her ay göndermem gereken 7 ayrı tablo var ve bunları her defasında ayrı ayrı pdf yapıp mail gönderiyorum.

Dediğiniz gibi 7 sayfayı tek pdf dosyası yapmak daha mantıklı olur. Tek dosyada nasıl toplarım.

Ocak butonu için PdfFile = PdfFile & "" & [B7] & ".pdf" Ocak 2019 Raporlar
Şubat butonu için ise PdfFile = PdfFile & "" & [B8] & ".pdf" ise Şubat 2019 Raporlar diye yazarım
tüm aylar için bu şekilde buton eklerim.

Teşekkür ederim.
 
[B7] hücresi yerine genel bir şey yazılabilir "Ocak 2019 Raporlar " ve yine pdf adı aynı olabilir ama pdf içinde sayfa adları sorun
onun içinde bir örnek yapayım

Ek dosyada ise

3 sayfayı ayrı ayrı 3 pdf yapıp
tek maille ekleyip gönderir
http://dosya.co/1drdxlqya85k/pdf.zip.html
 
PLİNT' Alıntı:
[B7] hücresi yerine genel bir şey yazılabilir "Ocak 2019 Raporlar " ve yine pdf adı aynı olabilir ama pdf içinde sayfa adları sorun
onun içinde bir örnek yapayım

Ek dosyada ise

3 sayfayı ayrı ayrı 3 pdf yapıp
tek maille ekleyip gönderir
http://dosya.co/1drdxlqya85k/pdf.zip.html
Genişletmek için tıkla ...

Teşekkür ederim Hocam,

Bu şekilde gönderdi ancak her tablonun hücreleri farklı

Aylık tabloda ocak ("$B$7:$R$78"), Şubat ise ("$T$7:$AJ$78")

Ürün ve marka bazında ocak ("$B$7:$X$78"), şubat ise ("$B$82:$X$153")

diğer tüm yedi tabloda aynı şekilde ama birbirinden farklı. Yaptığınız çalışmaya bu kısıtı nasıl verebilirim.

sayfalar = Array("Aylık", "Üretim Veri Analizi", "Ürün ve Marka Bazında")
yol = ThisWorkbook.Path
For m = 0 To UBound(sayfalar)
pdff = Sheets(sayfalar(m)).Name & ".pdf"
Sheets(sayfalar(m)).Range("$B$7:$R$78").ExportAsFixedFormat Type:=xlTypePDF,

Tablo hücrelerini nasıl tayin edebilirim.

Teşekkür ederim.
 
8. mesajdaki ekli dosyadaki gibi oluyorsa
sayfalar = Array("Aylık", "Üretim Veri Analizi", "Ürün ve Marka Bazında")
hcrler = Array("$B$7:$R$78", "$T$7:$AJ$78", "$B$7:$R$78")
yol = ThisWorkbook.Path
For m = 0 To UBound(sayfalar)
pdff = Sheets(sayfalar(m)).Name & ".pdf"
Sheets(sayfalar(m)).Range(hcrler(m)).ExportAsFixedFormat Type:=xlTypePDF,
 
Hocam,
Eklediğiniz her iki dosya da oldu.
sayfalar = Array("Aylık", "Üretim Veri Analizi", "Ürün ve Marka Bazında")
hcrler = Array("$B$7:$R$78", "$T$7:$AJ$78", "$B$230:$X$300") burada tabloları çoğaltmak için hücreleri belirlemek için sıralamayı takip etmek mi gerek?
Eklediğiniz iki dosyadan hangisini kullanmamı önerirsiniz.

Emeğiniz ve yardımlarınız için teşekkür ederim.
 
sayfalar listesindeki ilk sayfa adının alınacak hücre aralığı; hcrler listesinde ilk olmalı öyle takip etmeli
Hangi dosyayı kullanırsanız artık onu siz bilirsiniz
 
Hocam,

Son olarak bi değişiklik yapmak istiyorum pdf isimlerini sayfalardan değilde hücrelerden alabilir mi

pdff = Sheets(sayfalar(m)).Name & ".pdf"
 
Ayrı dosya oluşturan kodlar için
pdff = Sheets(sayfalar(m)).range("C7") & ".pdf"

sayfaları tek dosya yapan için
pdff = Sheets("Aylık").range("C7") & ".pdf"
 
Bu şekilde yaptım
pdff = Sheets("Aylık").Range("B7") & ".pdf" & Sheets("Üretim Veri Analizi").Range("B7") & ".pdf" & Sheets("Ürün ve Marka Bazında").Range("B230") & ".pdf"

ancak burada hata veriyor

Kill ThisWorkbook.Path & "\" & Split(PdfFile, ";")(t)


yani yapmak istediğim her tablonun ilk hücresi pdf dosya adı olsun
(Aylık $B$7), (Üretim Veri Analizi $T$7) ve (Ürün ve Marka Bazında $B$230) gibi
diğer tüm 7 tablo içinde böyle yapmak istiyorum
 
Merhaba
Aşağıdaki gibi olabilir
'...Mail gönderen bölümdede değişiklik yaparsınız
Kod: 
'....'
'.....kodlarınız'
'....'
sayfalar = Array("Aylık", "Üretim Veri Analizi", "Ürün ve Marka Bazında")
hcrler = Array("B7", "B7", "B230")
yol = ThisWorkbook.Path
For m = 0 To UBound(sayfalar)
Pdff = Sheets(sayfalar(m)).Name & ".pdf"
Sheets(sayfalar(m)).Range(hcrler(m)).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol & "\" & Pdff, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Pdff2 = Pdff2 & Pdff  '__________________
Next
'...
'...Mail gönderen BÖLÜMDEDE DEĞİŞİKLİK YAPIN
'.............
For t = 0 To UBound(Split(Pdff2, ".pdf")) - 1
Kill ThisWorkbook.Path & "\" & Split(Pdff2, ".pdf")(t) & ".pdf"
Next
'......
'diğer kodlarınız
'.......'
'.....
End sub'
 
Son düzenleme:
Hocam,
Emeğiniz ve yardımlarınız için teşekkür ederim. 17. mesajdaki kodları denedim mail gönderiyor ama hiç bir dosya eklemedi.
 
Dosyaları silen bölüm gibi,dosyaları mail e ekleyen satırları da değişmeliydiniz
Kod: 
'...
'...
   For t = 0 To UBound(Split(Pdff2, ".pdf")) - 1
.Attachments.Add ThisWorkbook.Path & "\" & Split(Pdff2, ".pdf")(t) & ".pdf"
Next
'...
'....
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst