Makro Yardımı

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
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

turist

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
5,102
Excel Vers. ve Dili
2013 64Bit
English
İ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
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Merhaba,

Yardımınız için teşekkür ederim. Denedim oldu, emeğinize sağlık..
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
834
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst