Word dosyasındaki sayfaları gruplar halinde kaydetme

[otugen]

Merhabalar
Word’ün adres, mektup birleştirme özelliğiyle hazırlanmış 300 sayfa civarında bir dokümanım var. Bu dokumanın her üç sayfasını farklı bir isimle kaydetmek istiyorum.
Bu isimleri yine excel’deki bir sütundan almak istiyorum.
İlginize şimdiden teşekkürler.

 

[leumruk]

Merhabalar
Word’ün adres, mektup birleştirme özelliğiyle hazırlanmış 300 sayfa civarında bir dokümanım var. Bu dokumanın her üç sayfasını farklı bir isimle kaydetmek istiyorum.
Bu isimleri yine excel’deki bir sütundan almak istiyorum.
İlginize şimdiden teşekkürler.

Merhaba,
Oluşturulacak word dosyalarına vereceğiniz isimleri içeren excel dosyasını ekleyin, üzerinde çalışayım.

 

[otugen]

Adres mektup birleştirme ve Farklı kaydet

Merhabalar
Dosyayı ekte gönderiyorum.
Dosya isimlerini 2. sütündan çekmek istiyorum.

İlgin için çok teşekkürler

 

[leumruk]

Merhaba,
Klasörü rardan çıkarıp excel dosyasını açın ve sayfadaki çalıştır butonuna basın. Çıkan ekrandan ayırmak istediğiniz word dosyasını seçin. Dosyalar Yeni klasörüne oluşturulacak.

Sub Sayfa_Ayir()
yol = ThisWorkbook.Path & "\"
Set wd = CreateObject("word.Application")
ChDir "c:\"
    wrd = Application.GetOpenFilename(",*.doc*")
    If wrd = False Then Exit Sub
wd.Application.Documents.Open wrd
wd.Visible = True
Ad = Split(wrd, "\")
uzanti = Split(Ad(UBound(Ad)), ".")
uzanti = "." & uzanti(UBound(uzanti))
wd.Selection.WholeStory
wd.Selection.Delete
wd.ActiveDocument.SaveAs Filename:=yol & "Sablon" & uzanti
Set dsy2 = wd.Documents("Sablon" & uzanti)
wd.Application.Documents.Open wrd
Set dsy1 = wd.Documents(Ad(UBound(Ad)))
Application.ScreenUpdating = False
dsy1.Activate
Son = wd.Selection.Information(4)
For x = 1 To Son Step 3
Say = Say + 1
For y = x To x + 2
If y <= Son Then
dsy1.Activate
wd.Selection.GoTo What:=1, Which:=2, Name:=y
wd.ActiveDocument.Bookmarks("\page").Range.Copy
dsy2.Activate
wd.Selection.Paste
wd.Selection.MoveRight Unit:=1, Count:=1
End If
Next
wd.Selection.GoTo What:=1, Which:=2, Name:=wd.Selection.Information(4)
krktr = wd.ActiveDocument.Bookmarks("\page").Range.ComputeStatistics(Statistic:=3)
If krktr = 0 Then wd.ActiveDocument.Bookmarks("\page").Range.Delete
wd.ActiveDocument.SaveAs Filename:=yol & "Yeni\" & Cells(Say + 1, 2) & uzanti
Set dsy2 = wd.Documents(Cells(Say + 1, 2) & uzanti)
wd.Selection.WholeStory
wd.Selection.Delete
Next
dsy2.Close False
dsy1.Application.Quit
Kill (yol & "Sablon" & uzanti)
MsgBox "Ayırma işlemi tamamlanmıştır.", vbInformation, "l e u m r u k"
End Sub

 

[otugen]

Harika bir iş.
Çok teşekkürler.