• FORUMU MOBİL UYGULAMADAN TAKİP EDİN

    Forumu isteyen üyelerimiz Tapatalk (Harici bir hizmet) üzerinden mobil uygulamadan takip edebilirler.
    iOS için : https://itunes.apple.com/app/id307880732?mt=8
    Android için : https://play.google.com/store/apps/details?id=com.quoord.tapatalkpro.activity
    adreslerinden indirebilirsiniz.

    Bir iki haftaya da foruma özel kendi uygulamamız yayında olacak.
ALTIN ÜYELİK Hakkında Bilgi
-----------------------

Makro Yardımı

Dunya_

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
332
Beğeniler
0
Excel Vers. ve Dili
2007
#1
Merhaba,

İki farklı makroyu tek buton altında çalıştırmak istiyorum ancak kodları birleştiremedim.

1.Kod
Kod:
Sub VeriyeGoreKopya()
 
If [E2] = "" Then
MsgBox "Lütfen Tarih Giriniz!", vbCritical
Range("E2").Select
GoTo 10
Else

'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'Vardiya Üretim Raporu Bilgisayara Kayıt
Set nesne = CreateObject("Scripting.FileSystemObject")
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
AyAdi = Format(Date, "mmmm yyyy") & " Vardiya Üretim Raporları"
klasoradi = Format(Date, "dd.mm.yyyy") & " " & [E2]
dosyaadi = [E2] & "  " & [E3]
klasorara = nesne.FolderExists(masaustuyolu & "\" & AyAdi)
If klasorara = False Then nesne.CreateFolder masaustuyolu & "\" & AyAdi

ActiveSheet.Range("$B$2:$K$85").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        masaustuyolu & "\" & AyAdi & "\" & dosyaadi & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
        
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
        
'Vardiya Üretim Raporu Servere Kayıt
'Set nesne = CreateObject("Scripting.FileSystemObject")
Server = "\\192.168.1.242\ortak\Üretim"
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
AyAdi = Format(Date, "mmmm yyyy") & " Vardiya Üretim Raporları"
klasoradi = Format(Date, "dd.mm.yyyy") & " " & [E2]
dosyaadi = [E2] & "  " & [E3]
klasorara = nesne.FolderExists(Server & "\" & AyAdi)
If klasorara = False Then nesne.CreateFolder Server & "\" & AyAdi

ActiveSheet.Range("$B$2:$K$85").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Server & "\" & AyAdi & "\" & dosyaadi & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------


'Yazdırma
   'ActiveSheet.PageSetup.PrintArea = "$B$2:$K$85"
    'ActiveWindow.SelectedSheets.PrintOut Copies:=2, Collate:=True, _
    'IgnorePrintAreas:=False

      
      
' Temizleme

Range( _
        "J5:K5,K46,K47,E2:K4,C9:C13,C15:C21,C23:C26,C28:C31,C33:C35,C37:C39,E9:F13,E15:F21,E23:F26,E28:F31,E33:F35,E37:F39,H9:I13,H15:I21,H23:I25,H26,I26,H28:I30,H31,I31,H33:I34,H35,I35,H37:I39,C60:K61,C63:K64,C66:K67,C69:K70,C72:K72,C75:K75,C78:K78" _
        ).Select
        Selection.ClearContents
    
    Range("C9").Select
    Range("E2").Select
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------


'ActiveCell.FormulaR1C1 = "=TODAY()"
'Range("E15").Select
    
MsgBox "PDF olarak kaydedildi...  Tablo Temizlendi...  İşleminiz tamamlanmıştır..!"




End If
10:
End Sub
2.Kod
Kod:
Private Sub CommandButton1_Click()

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

  Title = Range("E2") & " - " & Range("E3")

  'PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & " " & [E2] & "  " & [E3] & ".pdf"

  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  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 = "....@gmail.com" ' Kime
    .CC = "....@gmail.com" ' bilgi olarak kime
    .Body = "Selamun aleykum," & vbLf & vbLf _
          & "Bu rapor PDF rapor içermektedir." & vbLf & vbLf _
          & "Hayirli gunler" & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "zaza"
    Else
      MsgBox "E-mail gonderildi", vbInformation, "zaza"
    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.
 

turist

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
4,281
Beğeniler
215
Excel Vers. ve Dili
Excel2013 English
64Bit
#2
İlk Makroyu silmeyin.
İkinci Makronuzu aşağıdaki gibi düzenleyin.
Eğer gerekirse İlk makrodaki
MsgBox "PDF olarak kaydedildi... Tablo Temizlendi... İşleminiz tamamlanmıştır..!"
satırını silin.
Deneyin.
Rich (BB code):
Private Sub CommandButton1_Click()

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

  Title = Range("E2") & " - " & Range("E3")

  'PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & " " & [E2] & "  " & [E3] & ".pdf"

  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  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 = "....@gmail.com" ' Kime
    .CC = "....@gmail.com" ' bilgi olarak kime
    .Body = "Selamun aleykum," & vbLf & vbLf _
          & "Bu rapor PDF rapor içermektedir." & vbLf & vbLf _
          & "Hayirli gunler" & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile

    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "zaza"
    Else
      MsgBox "E-mail gonderildi", vbInformation, "zaza"
    End If
    On Error GoTo 0

  End With

  Kill PdfFile

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing




End Sub
 

Dunya_

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
332
Beğeniler
0
Excel Vers. ve Dili
2007
#5
Merhaba Hocam,

İkici kodda bulunan
Kod:
Subject = Title
    .To = "....@gmail.com" ' Kime
    .CC = "....@gmail.com" ' bilgi olarak kime
    .Body =
.Body kısmında yazılacak mesajın font ve boyutunu ( Bold 12 ) olarak nasıl değiştirebilirim.

Yardımlarınız için teşekkür ederim.
 
Üst