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

mrtylmzzz · 13 Eylül 2024

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 · 13 Eylül 2024

Merhaba, örnek dosya ekleyecek misiniz?

mrtylmzzz · 13 Eylül 2024

necati' Alıntı:
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 · 14 Eylül 2024

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

mrtylmzzz · 14 Eylül 2024

necati' Alıntı:
İ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 · 14 Eylül 2024

Kod:

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 · 14 Eylül 2024

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 · 14 Eylül 2024

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

Kod:

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 · 14 Eylül 2024

necati' Alıntı:

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

Kod:

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 · 14 Eylül 2024

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 · 14 Eylül 2024

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 · 14 Eylül 2024

mrtylmzzz' Alıntı:
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 · 14 Eylül 2024

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

necati · 14 Eylül 2024

Rica ederim kolay gelsin.

expercions · 8 Ağustos 2025

necati' Alıntı:
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

Necati bey merhaba, benzer bir sorunumda benim var. yardımcı olursanız cok sevinirim. adres mektup birleştirmeden ürettiğim 110 sayfalık word belgesini pdf olarak tek tek kaydetmek istiyorum. ancak her sayfanın 2. satırı isimler var. bu isimleride dosya ismi olarak vermek istiyorum. ...

isimleri alamadan işlemi şu şekilde yapabiliyorum =>

**************************
Sub SaveAsSeparatePDFs()
'Updated by Extendoffice 20180906
Dim I As Long
Dim xStr As String
Dim xPathStr As Variant
Dim xDictoryStr As String
Dim xFileDlg As FileDialog
Dim xStartPage, xEndPage As Long
Dim xStartPageStr, xEndPageStr As String
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show <> -1 Then
MsgBox "Please chose a valid directory", vbInformation, "Kutools for Word"
Exit Sub
End If
xPathStr = xFileDlg.SelectedItems(1)
xStartPageStr = InputBox("Begin saving PDFs starting with page __? " & vbNewLine & "(ex: 1)", "Kutools for Word")
xEndPageStr = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 7)", "Kutools for Word")
If Not (IsNumeric(xStartPageStr) And IsNumeric(xEndPageStr)) Then
MsgBox "The enterng start page and end page should be number format", vbInformation, "Kutools for Word"
Exit Sub
End If
xStartPage = CInt(xStartPageStr)
xEndPage = CInt(xEndPageStr)
If xStartPage > xEndPage Then
MsgBox "The start page number can't be larger than end page", vbInformation, "Kutools for Word"
Exit Sub
End If
If xEndPage > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Then
xEndPage = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
End If
For I = xStartPage To xEndPage
ActiveDocument.ExportAsFixedFormat xPathStr & "\Page_" & I & ".pdf", _
wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, I, I, wdExportDocumentWithMarkup, _
False, False, wdExportCreateHeadingBookmarks, True, False, False
Next
End Sub

necati · 8 Ağustos 2025

Merhaba,

Kod:

Sub Sayfalar_Pdf()
Dim Rng As Range, i As Long, isim As String

With ActiveDocument
    For i = 1 To .ComputeStatistics(wdStatisticPages)
        Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
        Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
        isim = Rng.Paragraphs(2).Range.Text
        isim = Replace(isim, vbCr, "")
        .ExportAsFixedFormat .Path & "\" & isim & ".pdf", _
        wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, i, i, wdExportDocumentWithMarkup, _
        False, False, wdExportCreateHeadingBookmarks, True, False, False
    Next
End With

MsgBox "İşlem tamam", vbInformation

End Sub

expercions · 9 Ağustos 2025

necati' Alıntı:

Merhaba,

Kod:

Sub Sayfalar_Pdf()
Dim Rng As Range, i As Long, isim As String

With ActiveDocument
    For i = 1 To .ComputeStatistics(wdStatisticPages)
        Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
        Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
       isim = Rng.Paragraphs(2).Range.Text
        isim = Replace(isim, vbCr, "")
        .ExportAsFixedFormat .Path & "\" & isim & ".pdf", _
        wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, i, i, wdExportDocumentWithMarkup, _
        False, False, wdExportCreateHeadingBookmarks, True, False, False
    Next
End With

MsgBox "İşlem tamam", vbInformation

End Sub

isim = Rng.Paragraphs(2).Range.Text

run-time error '5941'
Grupta listelenen eleman yok hatası veriyor

necati · 9 Ağustos 2025

expercions' Alıntı:
isim = Rng.Paragraphs(2).Range.Text

run-time error '5941'
Grupta listelenen eleman yok hatası veriyor

Demekki 2. Paragraf benim düşündüğüm şekilde değilmiş. Örnek dosya eklenirse değerlendirilebilir.

expercions · Salı saat 15:39'de

necati' Alıntı:
Demekki 2. Paragraf benim düşündüğüm şekilde değilmiş. Örnek dosya eklenirse değerlendirilebilir.

İndir DEĞERLİ BAYİMİ topl22 docx

Dosyayı indir DEĞERLİ BAYİMİ topl22 docx

dosya.co

yükledim

necati · Salı saat 19:14'de

Sn expercions, sizin aldığınız hatayı ben almıyorum. Örnek dosyanızda 2. paragraflarda bir problem görünmüyor. Sadece bölüm sonlarından kaynaklı problem olabilir, çünkü sayfalar birbirinden bu şekilde ayrılmış. Bölüm sonlarına göre revize edilen makroyu ekliyorum.

Kod:

Sub Sayfalar_Pdf2()
Dim i As Long, isim As String

With ActiveDocument
    For i = 1 To .Sections.count
        With .Sections(i)
            isim = Split(.Range.Paragraphs(2).Range.Text, vbCr)(0)
            ActiveDocument.ExportAsFixedFormat ActiveDocument.Path & "\" & isim & ".pdf", _
            wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, i, i, wdExportDocumentWithMarkup, _
            False, False, wdExportCreateHeadingBookmarks, True, False, False
        End With
    Next
End With

MsgBox "İşlem tamam", vbInformation

End Sub