VBA ile Word dosyasındaki belirli sayfaları isim seçerek yazdırmak

[mrtylmzzz]

Arkadaşlar merhaba,
desteklerinize ihtiyaç duyuyorum. Şöyle 100 küsür sayfalık bir word dosyam var. bu 100 küsür sayfalık dosyada her tek sayılı olan sayfada ilgili kişinin adı soyadı çift sayfalarda ise ilgili kişiyle özel hazırlanmış bir metin var.

amacım bu dosyaları kişinin ismi olacak şekilde vba yardımıyla pdf olarak kaydetmek.
Örneğin;

-1. sayfanın bir yerinde murat yazıyor. 2. sayfada murata özel yazılmış bir yazı var. ben makroyu çalıştırdığımda dosyanın adını murat.pdf olarak kaydedecek ve sadece 1. ve 2. sayfayı bastıracak.
-3. sayfanın bir yerinde fatma yazıyor. 4. sayfada fatmaya özel yazılmış bir yazı var. makro çalışmaya devam ettiğinde bu dosyanın adını fatma.pdf olarak kaydedecek ve sadece 3. ve 4. sayfayı bastıracak.

bu durum böyle n tane kişi için devam ediyor. vba son sayfaya gelene kadar kaç kayıt varsa yukarıdaki gibi pdf olarak kaydetsin istiyorum.

Konunun üstadlarının desteğine ihtiyaç duyuyorum. aksi halde tek tek çok zor oluyor.

 

[necati]

Merhaba, örnek dosya ekleyecek misiniz?

 

[mrtylmzzz]

k dosya ekleyecek misi

belge.docx dosyasını indir - download

belge.docx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

ilgiliniz için teşekkürler. örneğin ekteki belgeyi yukarıda paylaştığım gibi pdf olarak kaydedebilmek istiyorum.

 

[necati]

İsimlerin yeri sabit mi? Tüm tek sayfaların ilk satırı isim diyebiliyor muyuz?

 

[mrtylmzzz]

İsimlerin yeri sabit mi? Tüm tek sayfaların ilk satırı isim diyebiliyor muyuz?

belge.docx dosyasını indir - download

belge.docx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

her tek sayılı sayfadaki sol alt kısımdaki yeri alması gerekiyor hocam kırmızı ile belirttiğim yer

 

[necati]

Sub PdfKaydet2()
Dim docC As Document, docN As Document
Dim i As Integer, k As Integer
Dim rCopy As Range
Dim isim As String

Selection.HomeKey Unit:=wdStory
Set docC = ActiveDocument
k = ActiveDocument.Content.Information(wdActiveEndPageNumber)

For i = 1 To k Step 2
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
    Selection.MoveEnd wdCharacter, -2
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    isim = Application.CleanString(Selection.Text)
    
    Set rCopy = ActiveDocument.GoTo(What:=wdGoToPage, _
        Which:=wdGoToAbsolute, Count:=i)
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
    rCopy.End = Selection.Bookmarks("\Page").Range.End
    rCopy.Copy
    
    Set docN = Documents.Add
    Selection.Paste
    Selection.TypeBackspace
    Selection.TypeBackspace
    docN.ExportAsFixedFormat OutputFileName:= _
        ThisDocument.Path & "\" & isim & ".pdf" _
        , ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=2, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
        CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=False, UseISO19005_1:=False
    docN.Close SaveChanges:=wdDoNotSaveChanges
Next i

MsgBox "Sayfalar kaydedildi.", vbInformation

End Sub

 

[mrtylmzzz]

ilginiz için teşekkür ederim ancak komutu size gönderdiğim dosyada çalıştırmak istediğimde şu hata geliyor.
Run-time error '-2147467259 (80004005)
Dışarı aktarma işlemi başarısız oldu. Belge dışarı aktarılmak üzere hazırlanamadı.

bu uyarıya ok dediğimde de "bellek ve disk alanı yetersiz . word istenen yazı tipini görüntüleyemiyor." uyarısı alıyorum :/

 

[necati]

Export esnasında hata alıyorsunuz galiba. İşi biraz daha sadeleştirelim.

Sub PdfKaydet2()
Dim docC As Document, docN As Document
Dim i As Integer, k As Integer
Dim rCopy As Range
Dim isim As String

Selection.HomeKey Unit:=wdStory
Set docC = ActiveDocument
k = ActiveDocument.Content.Information(wdActiveEndPageNumber)

For i = 1 To k Step 2
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
    Selection.MoveEnd wdCharacter, -2
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    isim = Application.CleanString(Selection.Text)
    
    Set rCopy = ActiveDocument.GoTo(What:=wdGoToPage, _
        Which:=wdGoToAbsolute, Count:=i)
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
    rCopy.End = Selection.Bookmarks("\Page").Range.End
    rCopy.Copy
    
    Set docN = Documents.Add
    Selection.Paste
    Selection.TypeBackspace
    Selection.TypeBackspace
    docN.ExportAsFixedFormat OutputFileName:=ThisDocument.Path & "\" & isim & ".pdf", ExportFormat:=wdExportFormatPDF
    docN.Close SaveChanges:=wdDoNotSaveChanges
Next i

MsgBox "Sayfalar kaydedildi.", vbInformation

End Sub

 

[mrtylmzzz]

Export esnasında hata alıyorsunuz galiba. İşi biraz daha sadeleştirelim.

Sub PdfKaydet2()
Dim docC As Document, docN As Document
Dim i As Integer, k As Integer
Dim rCopy As Range
Dim isim As String

Selection.HomeKey Unit:=wdStory
Set docC = ActiveDocument
k = ActiveDocument.Content.Information(wdActiveEndPageNumber)

For i = 1 To k Step 2
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
    Selection.MoveEnd wdCharacter, -2
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    isim = Application.CleanString(Selection.Text)
   
    Set rCopy = ActiveDocument.GoTo(What:=wdGoToPage, _
        Which:=wdGoToAbsolute, Count:=i)
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1
    rCopy.End = Selection.Bookmarks("\Page").Range.End
    rCopy.Copy
   
    Set docN = Documents.Add
    Selection.Paste
    Selection.TypeBackspace
    Selection.TypeBackspace
    docN.ExportAsFixedFormat OutputFileName:=ThisDocument.Path & "\" & isim & ".pdf", ExportFormat:=wdExportFormatPDF
    docN.Close SaveChanges:=wdDoNotSaveChanges
Next i

MsgBox "Sayfalar kaydedildi.", vbInformation

End Sub

zahmet veriyorum size ama. bu kezde sayfalar kaydedildi uyarısı geliyor ancak herhangi bir yere pdf dosyası kaydetmiyor.
özellikle word dosyasını yeni bir klasör açıp oraya ekledim. vba yı çalıştırdım msgbox daki sayfalar kaydedildi bilgisi geldi ancak hiç bir yere kayıt edilmiş bir pdf yok. siz yaptığınızda oluyor muydu? hani başka bir yere kaydetmiştir diye bilgisayarı da arattım ama oluşturulmuş bir pdf dosyası görünmüyor.

 

[necati]

Dosyaların kayıt yeri word belgesinin olduğu yerdir. F8 ile adımlayıp ne yaptığını tesbit edebilirseniz nerede ne yapıyor veya yapmıyor ayrıntı verebilirseniz iyi olur. Şimdilik bilgisayardan ayrılıyorum. Daha sonra bakabileceğim.

 

[mrtylmzzz]

bandicam_2024-09-14_14-12-44-961.mp4 dosyasını indir - download

bandicam_2024-09-14_14-12-44-961.mp4 dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

hocam yaptığım işlemleri buraya ekran kaydı aldım.

 

[necati]

bandicam_2024-09-14_14-12-44-961.mp4 dosyasını indir - download

bandicam_2024-09-14_14-12-44-961.mp4 dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

hocam yaptığım işlemleri buraya ekran kaydı aldım.

Temp klasörüne (C:\Users\...........\AppData\Roaming\Microsoft\Templates) kaydetmiş. ister oradan alın, ister ilgili satırı değiştiriniz.
docN.ExportAsFixedFormat OutputFileName:=ThisDocument.Path & "\" & isim & ".pdf", ExportFormat:=wdExportFormatPDF

yenisi bu şekilde olmalı.
docN.ExportAsFixedFormat OutputFileName:=docC.Path & "\" & isim & ".pdf", ExportFormat:=wdExportFormatPDF

 

[mrtylmzzz]

destekleriniz için sonsuz teşekkürler. çok ilgilendiniz.
şuan çalışıyor

 

[necati]

Rica ederim kolay gelsin.