Word Sayfa Aralığını Farklı Kaydetmek

[RedStar]

Arkadaşlar kolay gelsin.

Tiff uzantılı 300 kadar dosyayı wordde yeni bir sayfa açarak yapıştırdım. Yapmak istediğim vereceğim sayfa aralığında kalan sayfaları farklı kaydetmek istiyorum. Mesala 350 sayfalık Word dosyasından 15-33 sayfa aralığını farklı kaydetmek istiyorum. İlgi ve alakanız için teşekkür ederim.

 

[RedStar]

Anlayan arkadaşlar yardımcı olursa sevinirim teşekkür ederim.

 

[Necdet]

Merhaba,

Deneme şansım yok.
Yazdır,
özel sayfalar
Dosyaya Yazdır

gibi seçenekler olması gerekiyor, bir deneyiniz.(Tahmini yazdım)

 

[leumruk]

Selamlar,
Deneyiniz:

Sub sayfakaydet()
ChDir "c:\"
Set wd = CreateObject("word.Application")
wrd = Application.GetOpenFilename(",*.doc*")
If wrd = False Then Exit Sub
wd.Application.Documents.Open wrd
wd.Visible = True
uzanti = CreateObject("Scripting.FileSystemObject").GetExtensionName(wrd)
k = wd.Selection.Information(4)
tekrar:
ilk = Application.InputBox("Başlangıç sayfasını yazınız.", "Sayfa seçme", , , , , , 1)
son = Application.InputBox("Bitiş sayfasını yazınız.", "Sayfa seçme", , , , , , 1)
If ilk = False Or son = False Then Exit Sub
If ilk > k Or son > k Then
MsgBox "Girdiğiniz sayılar ile sayfa sayıları uyumsuz. Rakamları tekrar giriniz.", vbCritical, "UYARI": GoTo tekrar
End If
If ilk > son Then
MsgBox "Başlangıç numarası bitiş numarasından büyük olamaz. Rakamları tekrar giriniz.", vbCritical, "UYARI": GoTo tekrar
End If
For i = k To son + 1 Step -1
wd.Selection.Goto What:=1, Which:=2, Name:=i
wd.ActiveDocument.Bookmarks("\page").Range.Delete
Next i

For j = ilk - 1 To 1 Step -1
wd.Selection.Goto What:=1, Which:=2, Name:=j
wd.ActiveDocument.Bookmarks("\page").Range.Delete
Next
wd.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & ilk & "-" & son & "." & uzanti
If wd.Documents.Count = 1 Then
wd.Application.Quit
Else
wd.ActiveDocument.Close False
End If
MsgBox "Sayfa aralığı başarıyla kaydedildi.", vbInformation, "l e u m r u k"
End Sub

 

[RedStar]

Sayın leumruk çok teşekkür ederim.

 

[leumruk]

Sayın leumruk çok teşekkür ederim.

Rica ederim.

 

[halit3]

Alternatif kod
not: referanslarda bu olmalı

Microsoft Excel xx.x Object Library

Sub ford_sayfa_ayir()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")

objWord.Visible = True

yol = Application.GetOpenFilename("All Files (*.doc*),*.*.doc")
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

sayfa_sayisi = docWord.Range.Information(wdNumberOfPagesInDocument)

baslangıc = Application.InputBox("Başlangıç tarihini AY olarak giriniz.", "Sayfa sayısı " & sayfa_sayisi, "2", 400, 30, , Type:=1)
atla1:
If baslangıc = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

atla2:
bitis = Application.InputBox("Bitiş tarihini AY olarak giriniz.", "Sayfa sayısı " & sayfa_sayisi, "3", 400, 30, , Type:=1)
If bitis = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


If baslangıc <= 0 Then
MsgBox " baslangıc sıfırdan büyük sayı giriniz"
GoTo atla1
Exit Sub
End If

If bitis <= 0 Then
MsgBox "bitis sıfırdan den büyük sayı giriniz"
GoTo atla2
Exit Sub
End If

If bitis > sayfa_sayisi Then
MsgBox "Bitiş sayfası Sayfa sayısından büyük seçim yaptınız."
GoTo atla2
Exit Sub
End If

If baslangıc > sayfa_sayisi Then
MsgBox "Başlangıç sayfası Sayfa sayısından büyük seçim yaptınız."
GoTo atla1
Exit Sub
End If

If baslangıc > bitis Then
GoTo atla1
MsgBox "Başlangıç sayfası bitiş sayfasından büyük seçim yaptınız."
Exit Sub
End If

objWord.Selection.Goto What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=baslangıc
bas = objWord.Selection.Bookmarks("\Page").Range.Start
objWord.Selection.Goto What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=bitis
bit = objWord.Selection.Bookmarks("\Page").Range.End

objWord.ActiveDocument.Range(bas, bit).Select

objWord.Selection.Range.Copy
objWord.ActiveDocument.Range.Select
objWord.Selection.Range.Delete
objWord.Selection.Range.Paste

Application.DisplayAlerts = False
sat1 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & sat1 & ".doc"
docWord.SaveAs dosya_adi
docWord.Close

objWord.Quit SaveChanges:=wdSaveChanges

Set docWord = Nothing
MsgBox "işlem tamam"

End Sub

Sub ford_ayir()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Dim objWord As Word.Application
'Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

yol = ThisWorkbook.Path & "\deneme.doc"
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

baslangıc = 10
bitis = 20

objWord.Selection.Goto What:=1, Which:=2, Name:=baslangıc
bas = objWord.Selection.Bookmarks("\Page").Range.Start
objWord.Selection.Goto What:=1, Which:=2, Name:=bitis
bit = objWord.Selection.Bookmarks("\Page").Range.End
objWord.ActiveDocument.Range(bas, bit).Select

objWord.Selection.Range.Copy
objWord.ActiveDocument.Range.Select
objWord.Selection.Range.Delete
objWord.Selection.Range.Paste

Application.DisplayAlerts = False
sat1 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & sat1 & ".doc"
docWord.SaveAs dosya_adi
docWord.Close

objWord.Quit SaveChanges:=wdSaveChanges

Set docWord = Nothing
MsgBox "işlem tamam"

End Sub

 

[RedStar]

Sayın halit3

Referanslarda olması gereken Microsoft Excel 12.0 Object Library yerine Microsoft Excel 15.0 Object Library mevcut. Microsoft Excel 12.0 Object Library nereden bulabilirim nereye yüklemem lazım. Çalıştırınca aşağıdaki hatayı veriyor. Birde ekteki word dosya isimli word belgesinin içinemi kopyalamammı lazım bölmek istediğim bütün sayfaları.

objWord.Selection.Goto What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=baslangıc

 

[Asri]

Microsoft Excel 12.0 Object Library yerine Microsoft Excel xx.x Object Library numara önemli değil. Sizde hangi sürüm var ise onu seçin.
Missign yazan var ise işaretini kaldırın.