• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

M

mrtylmzzz

Katılım
15 Ocak 2012
Mesajlar
16
Excel Vers. ve Dili
2010 tr
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.
 
İsimlerin yeri sabit mi? Tüm tek sayfaların ilk satırı isim diyebiliyor muyuz?
 
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
 
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 :/
 
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
 
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
Genişletmek için tıkla ...

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.
 
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' 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 s6.dosya.tc

hocam yaptığım işlemleri buraya ekran kaydı aldım.
Genişletmek için tıkla ...

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
 
destekleriniz için sonsuz teşekkürler. çok ilgilendiniz.
şuan çalışıyor
 
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
Genişletmek için tıkla ...

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
 
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
 
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
Genişletmek için tıkla ...

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

run-time error '5941'
Grupta listelenen eleman yok hatası veriyor
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst