Yazdırma Mantığını Yazıcıya Değil Pdf Olarak Ayrı Ayrı Yazdırılabilir Mi?

Ben dosya adını yani yazdırdığım her dosya adı için Örneğin A1 hücresini referans alarak ( indis ile oraya numarayı getirteceğim-düşürteceğim) o sayfanın adını o hücreden alarak kaydetsin,

Kayıt yeri olarak da D sürücüsü içerisinde Daimi Arama klasörü içerisine kayıt etmesini,

Alternatif olarak da 1 ile 500 arası dijital çıktıyı tek tek kayıt yerine dosya adı önemli değil tek dosya olarak da alternatif makro ile bir tuşa bağlayıp yazdırmak istiyorum, kayıt yeri yine D sürücüsü olsun. Daimi Arama 2 klasörü olabilir.

dilerim işinize yarar
tek tek pdf kodu:

Baslik$ = "Yazdır."

Mesaj$ = "Belirlenen sayıya kadar yazdırılacak, Onaylıyormusunuz?"

cevap$ = MsgBox(Mesaj$, 4 + 32 + 0, Baslik$)

If cevap$ = 6 Then

Dim ilk As Integer

Dim son As Integer

Dim S1 As Worksheet

Dim S2 As Worksheet

Set S1 = Sheets("Sorgu")

Set S2 = Sheets("2")



ilk = S1.Range("E11").Value

son = S1.Range("J11").Value

For i = ilk To son

S1.Range("E3").Value = i

S2.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

        ActiveWorkbook.Path & "\" & i & "_hy.pdf", Quality:=xlQualityStandard, _

        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _

        False 'S2.PrintOut Copies:=1, Collate:=True

Next

MsgBox "Yazdırma İşlemi Gerçekleştirildi.", vbInformation, "Hazırlayan; Adli Büro "

End If



Set S1 = Nothing

Set S2 = Nothing

Toplu Pdf Kodu:

Baslik$ = "Yazdır."

Mesaj$ = "Belirlenen sayıya kadar yazdırılacak, Onaylıyormusunuz?"

cevap$ = MsgBox(Mesaj$, 4 + 32 + 0, Baslik$)

If cevap$ = 6 Then

Dim ilk As Integer

Dim son As Integer

Dim SonStr As Long

Dim S1 As Worksheet

Dim S2 As Worksheet

Dim TmpSHdf As Worksheet



Set S1 = Sheets("Sorgu")

Set S2 = Sheets("2")

'hy______________________________________

Application.ScreenUpdating = False

On Error GoTo ErrorHandler:



ThisWorkbook.Worksheets.Add.Name = "TmpSHdf"

Set TmpSHdf = Sheets("TmpSHdf")

ilk = S1.Range("E11").Value

son = S1.Range("J11").Value

SonStr = 0



For i = ilk To son

S1.Range("E3").Value = i

S2.Range("B1:J50").Copy

TmpSHdf.Range("A" & SonStr * 50 + 1).PasteSpecial xlPasteFormats

TmpSHdf.Range("A" & SonStr * 50 + 1).PasteSpecial xlPasteValuesAndNumberFormats

SonStr = SonStr + 1

Next

S2.Range("B1:J50").Copy

TmpSHdf.Range("A" & SonStr * 50 + 1).PasteSpecial xlPasteColumnWidths





TmpSHdf.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

        ActiveWorkbook.Path & "\" & ilk & "_" & son & "_Arası.pdf", Quality:=xlQualityStandard, _

        IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:= _

        False 'S2.PrintOut Copies:=1, Collate:=True



Application.DisplayAlerts = False

TmpSHdf.Delete

Application.DisplayAlerts = True



ErrorHandler:

Application.ScreenUpdating = True



'hy______________________________________

MsgBox "Yazdırma İşlemi Gerçekleştirildi.", vbInformation, "Hazırlayan; Adli Büro "

End If



Set S1 = Nothing

Set S2 = Nothing

Set TmpSHdf = Nothing

Kodları inceleyip dönüş yapacağım.

Filename:= _
ActiveWorkbook.Path & "\" & ilk & "_" & son & "_Arası.pdf" burası dosya adresi ve adının olduğu yerdir
oraya istediğinizi yazarsınız
Filename:= _
DosyaAdresi & "\" & dosyaAdı & ".pdf"

Toplu güzel olmuş yalnız dosya kayıt yeri D:\Daimi Arama01 Klasörüne kayıt yapsa daha güzel olacak.
Tek tek de güzel olmuş ama kayıt yeri D:\Daimi Arama02 Klasörüne kayıt yapsa ayrıca yazdırdığı sayfada B2 hücresindeki adı dosya adı olarak kaydederse süper olacak.