Soru Sayfaları Birleştir ve PDF Yap

[Hsn55]

Korhan bey Ömer bey'in yapmış olduğu makro işimi görüyor. Fakat sadece seçili sayfa tanımlaması yapılması gerekiyor. Rica etsem ilgili makroya ilave olarak CheckBox tanımlaması yapabilir misiniz ?. Yani CheckBox lardan hangisini seçersem makro seçili sayfaları PDF oluştursa

 

[Korhan Ayhan]

İnceleyiniz.

Onay kutuları için hücrelere çift tıklama yapmanız yeterli olacaktır.

Harici Link (silinebilir) ; https://dosyam.org/X3c/Seçili_Sayfaları_PDF_Kaydet.xlsm

 

[Hsn55]

Hocam link yükleyebilir misiniz

 

[Hsn55]

Korhan bey link yada kodu ekleyebilir misiniz?

 

[Korhan Ayhan]

Harici link ekledim. Deneyebilirsiniz.

 

[Hsn55]

Korhan bey çok teşekkür ederim. Aynı işlemi yazdırma olarak nasıl yapmalıyız.Yani yazdır butonuna bastığımızda sadece seçili olanları yazdıracak.Birde ayın işlemi yine sadece seçili olanları yazdıracak

 

[Korhan Ayhan]

Deneyiniz.

Sub Secili_Sayfalari_Yazdir()
    Dim Onay As Byte, Sayfa As Range

    Onay = MsgBox("Seçtiğiniz sayfaları yardırmak istediğinize emin misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
    
    If Onay = vbNo Then Exit Sub

    If WorksheetFunction.CountA(Sheets("ANASAYFA").Range("B7:B11")) = 0 Then
        MsgBox "Yazdırma işlemi için önce sayfa seçimi yapmalısınız!", vbCritical
        Exit Sub
    End If
        
    For Each Sayfa In Sheets("ANASAYFA").Range("B7:B11")
        If Sayfa.Value <> "" Then Sheets(CStr(Sayfa.Offset(, 1).Value)).PrintOut Copies:=1
    Next
    
    MsgBox "Seçtiğiniz sayfalar yazıcıya gönderilmiştir.", vbInformation
End Sub

 

[Hsn55]

Korhan bey makronun şurasında hata veriyor.

 Sheets(CStr(Sayfa.Value)).PrintOut , Copies:=1

 

[Korhan Ayhan]

Aradaki virgül fazla olmuş. Silip deneyiniz.

 

[Hsn55]

Gene aynı yerde hata veriyor

 

[Korhan Ayhan]

Revize ettim. Son halini tekrar deneyiniz.

 

[Hsn55]

Korhan bey hocam çok teşekkür derim .Ellerinize sağlık. Ana dosyamın son halini düzenledim. Sadece son olarak seçime göre pdf yapılan dosyanın mail gönderilmesi kaldı. Sizden olarak ricam; seçmiş olduğumuz sayfaları pdf yapıp ;
I13 Hücresinde: Gönderenin mail adresi var.
I15 Hücresinde: Alıcının e-mail adresi var
G5 Hücresi: Gidecek Dosyanın Adı
I9+G5 Hücresi : Konu Olacak
şekilde mail gönderebilir miyiz?

İndir PUANTAJ

Dosyayı indir PUANTAJ

dosya.co

 

[Hsn55]

Korhan bey hocam daha önceden yapmış olduğunuz e-mail makrosunu dosyama uyarladım .Sadece dosya yolunu masa üstüne Anasayfada G4 hücresindeki isimle oluşturulan klasörün içerisini dosya yolu olarak gösterebilir miyiz?

Sub DOSYA_GONDER()
        
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Uygulama As Object, Yeni_Mail As Object, Onay As Byte
    Dim Yol As String, Secilen_Dosyalar As Variant, Dosya As Variant
              
    Set S1 = Sheets("ANASAYFA")
    
    Beep
    
    Onay = MsgBox(S1.Range("I15") & " mail adresine göndermek istediğinize emin misiniz?", vbYesNo + vbDefaultButton2)
    If Onay = vbNo Then
        MsgBox "Mail gönderme işleminiz iptal edilmiştir.", vbExclamation
        Exit Sub
    End If
    
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
    ChDir Yol
    Secilen_Dosyalar = Application.GetOpenFilename(Title:="Lütfen mail olarak göndermek istediğiniz dosyaları seçiniz...", MultiSelect:=True)

    If IsArray(Secilen_Dosyalar) = False Then
        MsgBox "Dosya seçimi yapmadığınız için işlem iptal edilmiştir.", vbExclamation
        Exit Sub
    End If
    
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
 
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
 
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    With Yeni_Mail
        .SentOnBehalfOfName = S1.Range("I13").Value
        .To = S1.Range("I15").Value
        .Subject = S1.Range("I9").Value & " (" & S1.Range("G5").Value & " )"
        .HtmlBody = "Puantaj Cetveli Ekte Gönderilmiştir.!!!!!!" & vbCr & .HtmlBody
         For Each Dosya In Secilen_Dosyalar
            .Attachments.Add Dosya
         Next
        .Save
        .Send
    End With
    
    MsgBox S1.Range("I15") & " adresine mail gönderilmiştir", vbInformation
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Uygulama = Nothing
    Set Yeni_Mail = Nothing
End Sub

 

[Hsn55]

Korhan hocam yapmış olduğunuz sayfa seçimine göre yazdır komutu AnaSayfa üzerinde B7:B11 hücre aralığında ki tik işareti olanları yazdırıyor. Acaba yine aynı makro ile sayfaların karşısına D711 hücre aralığına her sayfanın karşısına girilen adet kadar o sayfa çıktısı alınabilir mi?

Sub Secili_Sayfalari_Yazdir()
    Dim Onay As Byte, Sayfa As Range

    Onay = MsgBox("Seçtiğiniz sayfaları yardırmak istediğinize emin misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
    
    If Onay = vbNo Then Exit Sub

    If WorksheetFunction.CountA(Sheets("ANASAYFA").Range("B7:B11")) = 0 Then
        MsgBox "Yazdırma işlemi için önce sayfa seçimi yapmalısınız!", vbCritical
        Exit Sub
    End If
        
    For Each Sayfa In Sheets("ANASAYFA").Range("B7:B11")
        If Sayfa.Value <> "" Then Sheets(CStr(Sayfa.Offset(, 1).Value)).PrintOut Copies:=1
    Next
    
    MsgBox "Seçtiğiniz sayfalar yazıcıya gönderilmiştir.", vbInformation
End Sub

Bilgi

Bilgi

dosyam.org

 

[Korhan Ayhan]

Aşağıdaki bölümü;

Copies:=1

Bu şekilde değiştirip deneyiniz.

Copies:=Sayfa.Offset(, 2).Value