Makro Yardımı

M

Mehmet Sait

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

Aşağıda ki kod ile raporları raporları PDF yapıp e-mail gönderiyorum. Aynı bu mantık ile PDF değilde excel sayfası oluşturmak istiyorum. Kodlarda ne gibi değişiklik yapılmalıyım.

Teşekkür ederim.

Kod: 
Sub Raporlama()

Application.ScreenUpdating = False

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
  Dim nesne As Object
  Dim yol As String, masaustuyolu As String
  Dim sor: Dim m As Long: Dim pdff As String: Dim pdff2 As String
  Dim altklas As String, s1 As Worksheet
Set s1 = Sheets("Raporlama")
Dim s2 As Worksheet
Dim st
Dim arm As Range, df As String
If s1.[B11] <> "" Then
df = Split(Trim(s1.[B11].Value), " ÜRETİM")(0)
st = MsgBox(df & " Üretim Değerlendirme Güncellenmesi yapılsın mı?", vbYesNo)
If st = vbYes Then
Set s2 = Sheets("Üretim Değerlendirme")
s2.Activate
Set arm = s2.Rows("2:2").Find(df, , xlValues, xlPart, xlByRows, , False, , False)
If Not arm Is Nothing Then
arm.Select
'*************************************************'
Call Sheets("Üretim Değerlendirme").kopru
'*************************************************'
s1.Activate
Else
st = MsgBox("Güncelleme yapılamadı işlem sonlansınmı?", vbYesNo)
If st = vbNo Then Exit Sub
End If
End If: End If
If WorksheetFunction.CountA(s1.Range("R1:R7")) <> 7 Then
MsgBox "Rapor Ayını Yenileyiniz"
Exit Sub
End If

If s1.[B11] = "" Then
s1.[B11].Select
MsgBox "Rapor seçiniz"
Exit Sub
End If
'...............................................

'..................................................................
Set nesne = CreateObject("Scripting.FileSystemObject")
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")

yol = masaustuyolu & "\" & Format(Date, "yyyy") & " Üretim Raporları"
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol

altklas = Format(Date, "dd.mm.yyyy") & " " & " - " & [B11]
yol = yol & "\" & altklas
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol
    
sayfalar = Array("Üretim Veri Analizi", "Dönemsel Karşılaştırma", "Aylık", "Ürün ve Marka Bazında", _
"Aylık Performans", "Hurda İcmali", "Üretim Değerlendirme")

For m = 0 To UBound(sayfalar)
pdff = Trim(s1.Range("R" & m + 1).Text) & ".pdf"
Sheets(sayfalar(m)).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol & "\" & pdff, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False

'------------------------------------------
Sheets(sayfalar(m)).Protect Password:="699"
'------------------------------------------
 
 pdff2 = pdff2 & pdff
Next
Range("R1:R7") = ""
sor = MsgBox("Dosyalar " & vbCrLf & yol & vbCrLf & "Klasörüne kaydedildi" & vbCrLf & _
"MAİL GÖNDERİLSİNMİ?", vbYesNo)
If sor = vbNo Then Exit Sub
If Range("C2") = "" Then MsgBox "Mail Adresi Yazınız": [C2].Select: Exit Sub
  Title = Range("B11")
  Kime = Range("C2")
  Bilgi = Range("C3")
  Gizli = Range("C4")
  Mesaj = Range("C5")
  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
    
    
For t = 0 To UBound(Split(pdff2, ".pdf")) - 1
.Attachments.Add yol & "\" & Split(pdff2, ".pdf")(t) & ".pdf"
Next
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, " MSC "
    End If
    On Error GoTo 0
 
  End With

Application.ScreenUpdating = True

If IsCreated Then OutlApp.Quit
  Set OutlApp = Nothing

End Sub
 
E

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
Merhaba bu kodlara bakıp birşey söylemek kendi adıma zor ama (örnek dosya olmadan) eğer isteğiniz excel olarak bir sayfayı mail eki yapmaksa aşağıda verdiğim linkdeki kodlar bu işlemi yapıyor , belki işinize yarar.

excel sayfasını e posta ile gönderme

merhaba arkadaşlar bir excel çalışma kitabı var içerisinde ise 5 sayfa var. sadece 3 nolu sayfayı e posta olarak gönderebiliyor muyuz ?
www.excel.web.tr www.excel.web.tr
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
EmrExcel16' Alıntı:
Merhaba bu kodlara bakıp birşey söylemek kendi adıma zor ama (örnek dosya olmadan) eğer isteğiniz excel olarak bir sayfayı mail eki yapmaksa aşağıda verdiğim linkdeki kodlar bu işlemi yapıyor , belki işinize yarar.

excel sayfasını e posta ile gönderme

merhaba arkadaşlar bir excel çalışma kitabı var içerisinde ise 5 sayfa var. sadece 3 nolu sayfayı e posta olarak gönderebiliyor muyuz ?
www.excel.web.tr www.excel.web.tr
Genişletmek için tıkla ...
Merhaba, Örnek dosya göndermek isterim ama boyut oldukça büyük. İstediğim dosya içindeki belli tabloları excel sayfası yapması. Mail atmasına gerek yok. PDF yapan bu makroyu excel olarak dönüştürmek.

Dışarıya çıkaran bu kısımda değişm olabilir mi diye düşündüm.

Kod: 
Set nesne = CreateObject("Scripting.FileSystemObject")
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")

yol = masaustuyolu & "\" & Format(Date, "yyyy") & " Üretim Raporları"
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol

altklas = Format(Date, "dd.mm.yyyy") & " " & " - " & [B11]
yol = yol & "\" & altklas
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol
    
sayfalar = Array("Üretim Veri Analizi", "Dönemsel Karşılaştırma", "Aylık", "Ürün ve Marka Bazında", _
"Aylık Performans", "Hurda İcmali", "Üretim Değerlendirme")

For m = 0 To UBound(sayfalar)
pdff = Trim(s1.Range("R" & m + 1).Text) & ".pdf"
Sheets(sayfalar(m)).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol & "\" & pdff, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Teşekkür ederim.
 
E

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
Dedim ya bu şekilde kendi adıma bu işin içinden çıkmak zor , kusura bakmayın yardımcı olamadım.
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,488
Excel Vers. ve Dili
Ofis 365 Türkçe
Örnek dosya göndermek isterim ama boyut oldukça büyük
Genişletmek için tıkla ...
Merhaba,

Adı üzerinde "Örnek Dosya". Önemli olan 3-5 satırlık bir dosya, ki kodları yazacak olan arkadaşlar bunları dikkate alsın.
 
P

PLİNT

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Aşağıdaki gibi deneyin
Kod: 
Sub Raporlama()

Application.ScreenUpdating = False

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
  Dim nesne As Object
  Dim yol As String, masaustuyolu As String
  Dim sor: Dim m As Long: Dim pdff As String: Dim pdff2 As String
  Dim altklas As String, s1 As Worksheet
Set s1 = Sheets("Raporlama")
Dim s2 As Worksheet
Dim st
Dim arm As Range, df As String
If s1.[B11] <> "" Then
df = Split(Trim(s1.[B11].Value), " ÜRETİM")(0)
st = MsgBox(df & " Üretim Değerlendirme Güncellenmesi yapılsın mı?", vbYesNo)
If st = vbYes Then
Set s2 = Sheets("Üretim Değerlendirme")
s2.Activate
Set arm = s2.Rows("2:2").Find(df, , xlValues, xlPart, xlByRows, , False, , False)
If Not arm Is Nothing Then
arm.Select
'*************************************************'
Call Sheets("Üretim Değerlendirme").kopru
'*************************************************'
s1.Activate
Else
st = MsgBox("Güncelleme yapılamadı işlem sonlansınmı?", vbYesNo)
If st = vbNo Then Exit Sub
End If
End If: End If
If WorksheetFunction.CountA(s1.Range("R1:R7")) <> 7 Then
MsgBox "Rapor Ayını Yenileyiniz"
Exit Sub
End If

If s1.[B11] = "" Then
s1.[B11].Select
MsgBox "Rapor seçiniz"
Exit Sub
End If
'...............................................

'..................................................................
Set nesne = CreateObject("Scripting.FileSystemObject")
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")

yol = masaustuyolu & "\" & Format(Date, "yyyy") & " Üretim Raporları"
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol

altklas = Format(Date, "dd.mm.yyyy") & " " & " - " & [B11]
yol = yol & "\" & altklas
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol
    
sayfalar = Array("Üretim Veri Analizi", "Dönemsel Karşılaştırma", "Aylık", "Ürün ve Marka Bazında", _
"Aylık Performans", "Hurda İcmali", "Üretim Değerlendirme")

Application.DisplayAlerts = False
For m = 0 To UBound(sayfalar)
pdff = Trim(s1.Range("R" & m + 1).Text) & ".xlsx"
Sheets(sayfalar(m)).Copy
ActiveWorkbook.SaveAs Filename:=yol & "\" & pdff, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
'------------------------------------------
Sheets(sayfalar(m)).Protect Password:="699"
'------------------------------------------
 pdff2 = pdff2 & pdff
Next
Application.DisplayAlerts = True


Range("R1:R7") = ""
sor = MsgBox("Dosyalar " & vbCrLf & yol & vbCrLf & "Klasörüne kaydedildi" & vbCrLf & _
"MAİL GÖNDERİLSİNMİ?", vbYesNo)
If sor = vbNo Then Exit Sub
If Range("C2") = "" Then MsgBox "Mail Adresi Yazınız": [C2].Select: Exit Sub
  Title = Range("B11")
  Kime = Range("C2")
  Bilgi = Range("C3")
  Gizli = Range("C4")
  Mesaj = Range("C5")
  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
    
    
For t = 0 To UBound(Split(pdff2, ".pdf")) - 1
.Attachments.Add yol & "\" & Split(pdff2, ".pdf")(t) & ".xlsx"
Next
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, " MSC "
    End If
    On Error GoTo 0
 
  End With

Application.ScreenUpdating = True

If IsCreated Then OutlApp.Quit
  Set OutlApp = Nothing

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst