• DİKKAT

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

100 Sayfalık Word Dosyasını Resime Göre Ayırmak

E

Eneserhat

Katılım
16 Eylül 2011
Mesajlar
26
Excel Vers. ve Dili
Microsoft Office 2016
Merhaba,

ekteki word dosyası gibi bir dosyayı 2 farklı word dosyası olarak kaydetmek mümkün mü? Her dosya üstteki resim ile başlayacak.

Üstten seçip bir sonraki resime kadar kopyalayıp yeni bir sayfaya yapışıtırıp dosyayı kaydediyorum. Ama çalıştığım dosyada 250 sayfa var ve her resim (antet) bir belgenin başlığı olacak.
 

Ekli dosyalar

Aşağıdaki kodu excel dosyasında bir modüle kapyala ve sayfada bir komut düğmesine bağla kodu çalıştır.

not: excel dosyası ile wodr dosyası aynı klasörün içinde yan yana olmalı
uyarı: kırmızı yere kendi word dosya adını yazınız.

ayrıca kodun çalışması için aşağıdaki referans olmalı
Kod: 
Microsoft Word 12.0 Object Library

Kod: 
Sub wordayir()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

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

objWord.Visible = True

Dim objWord2 As Word.Application
Dim docWord2 As Word.Document

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

ReDim veri(1000)

say9 = 0
For Each Picture In objWord.ActiveDocument.Shapes
say9 = say9 + 1
objWord.ActiveDocument.Shapes(say9).Select
veri(say9) = objWord.Selection.End
Next Picture

If say9 = 0 Then MsgBox "hiç resim nesnesi yok": GoTo atla

say9 = say9 + 1
veri(say9) = objWord.ActiveDocument.Range.End

For Each Picture In objWord.ActiveDocument.Shapes
i = i + 1
objWord.ActiveDocument.Shapes(i).Select
objWord.Selection.Copy

Set objWord2 = CreateObject("Word.Application")
objWord2.Visible = True
Set docWord2 = objWord2.Documents.Add(DocumentType:=wdNewBlankDocument)

objWord2.Selection.Paste

objWord2.Selection.TypeParagraph

objWord.ActiveDocument.Range(Start:=veri(i), End:=veri(i + 1)).Copy

objWord2.Selection.PasteSpecial Link:=False, DataType:=10
say10 = 0
For Each Picture2 In objWord2.ActiveDocument.Shapes
say10 = say10 + 1
objWord2.ActiveDocument.Shapes(say10).Top = 1
objWord2.ActiveDocument.Shapes(say10).Left = 1
Next Picture2


say5 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1

objWord2.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & say5 & ".doc"
objWord2.ActiveDocument.Close
objWord2.Quit
Application.CutCopyMode = False


Next Picture

atla:
Application.DisplayAlerts = False
docWord.Close False
objWord.Quit

Set docWord = Nothing
MsgBox "işlem tamam"
End Sub
 
Son düzenleme:
Merhaba;

Ben de aşağıdaki gibi bir kod hazırladım ama bu kod, Excel VBA değil; bölünmesini istediğiniz Word dokümanına yerleştirildikten sonra çalıştırılacak bir Word VBA kodu.

Bunun için ilk önce söz konusu Word dokümanınızı yedeklemenizi mutlaka öneririm.

Daha sonra;

-Word dokümanınızı açın ve klavyeden Alt+F11 tuş kombinasyonuyla Word'ün VBE penceresini açın.

-Excel'deki gibi, bu dokümana bir Modül ekleyin ve aşağıdaki kodları yapıştırın.

-Daha sonra, kodu çalıştırın.

Kod: 
Sub Test()
    For i = ActiveDocument.Shapes.Count To 1 Step -1
        PageNum = ActiveDocument.Shapes(i).Anchor.Information(wdActiveEndAdjustedPageNumber)
        Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNum
        Selection.EndKey Unit:=wdStory, Extend:=wdExtend
        Selection.Cut
        Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
        ChangeFileOpenDirectory ThisDocument.Path
        Selection.Paste
        ActiveDocument.SaveAs2 FileName:="Dokuman-" & i & ".docx"
        ThisDocument.Activate
    Next
    Selection.TypeText Text:="İşlem tamamlandı"
End Sub
Selamlar,


.
 
Son düzenleme:
Bu kod da birazcık forklı

Referanslardan bu olmalı

Kod: 
Microsoft Word 12.0 Object Library

Kod: 
Private Sub CommandButton1_Click()

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

Dim objWord2 As Word.Application
Dim docWord2 As Word.Document

yol = ActiveWorkbook.Path & "\deneme.doc"
Set docWord = objWord.Documents.Open(yol)

ReDim veri(1000)

say = 0
For Each Picture In objWord.ActiveDocument.Shapes
say = say + 1
veri(say) = objWord.ActiveDocument.Range(0, objWord.ActiveDocument.Shapes(say).Anchor.End).Paragraphs.Count
Next Picture

If say = 0 Then MsgBox "hiç resim nesnesi yok": GoTo atla
say = say + 1
veri(say) = objWord.ActiveDocument.Paragraphs.Count + 1

sat = 0

For Each Picture In objWord.ActiveDocument.Shapes
sat = sat + 1

Set objWord2 = CreateObject("Word.Application")
objWord2.Visible = True
Set docWord2 = objWord2.Documents.Add(DocumentType:=wdNewBlankDocument)

objWord.ActiveDocument.Range(objWord.ActiveDocument.Paragraphs(veri(sat)).Range.Start, objWord.ActiveDocument.Paragraphs(veri(sat + 1) - 1).Range.End).Copy
objWord2.Selection.Paste

son = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1

objWord2.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & son & ".doc"
objWord2.ActiveDocument.Close
objWord2.Quit
Application.CutCopyMode = False

Next Picture

atla:

docWord.Close False
objWord.Quit

Set docWord = Nothing
MsgBox "işlem tamam"

End Sub
 

Ekli dosyalar

Son düzenleme:
Ben de yukarıda önerdiğim kodu, daha sağlıklı olduğunu düşündüğüm aşağıdaki şekliyle revize ettim.

Kod: 
Sub Test2()
    For i = ActiveDocument.Shapes.Count To 1 Step -1
        ActiveDocument.Shapes(i).Anchor.Paragraphs(1).Range.Select
        Selection.EndKey Unit:=wdStory, Extend:=wdExtend
        Selection.Cut
        Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
        Selection.Paste
        ActiveDocument.SaveAs ThisDocument.Path & "Dokuman-" & i & ".docx"
        ThisDocument.Activate
    Next
    Selection.TypeText Text:="İşlem tamamlandı"
End Sub
 
Son düzenleme:
Merhaba,
Bir alternatif de ben ekleyeyim. Makro word üzerinde düzenlenmiştir.
Kod: 
Sub Makro1()
say = ActiveDocument.Shapes.Count
Set wd = CreateObject("Word.Application")
wd.Visible = True
Set yenidoc = wd.Documents.Add(DocumentType:=0)

For x = Selection.Information(4) To 1 Step -1

Selection.GoTo What:=1, Which:=2, Name:=x
obj = ActiveDocument.Bookmarks("\page").Range.ShapeRange.Count

ActiveDocument.Bookmarks("\page").Range.Copy
wd.Selection.HomeKey Unit:=6
wd.Selection.Paste

If obj > 0 Then
wd.ActiveDocument.SaveAs (ActiveDocument.Path & "\" & say & ".doc")
wd.ActiveDocument.Close False
If x = 1 Then wd.Application.Quit
If x <> 1 Then Set yenidoc = wd.Documents.Add(DocumentType:=0)
say = say - 1
End If

Next

MsgBox "İşlem tamamlandı.", vbOKOnly, "l e u m r u k"

End Sub
 
halit3' Alıntı:
Aşağıdaki kodu excel dosyasında bir modüle kapyala ve sayfada bir komut düğmesine bağla kodu çalıştır.

not: excel dosyası ile wodr dosyası aynı klasörün içinde yan yana olmalı
uyarı: kırmızı yere kendi word dosya adını yazınız.

ayrıca kodun çalışması için aşağıdaki referans olmalı
Kod: 
Microsoft Word 12.0 Object Library

Kod: 
Sub wordayir()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

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

objWord.Visible = True

Dim objWord2 As Word.Application
Dim docWord2 As Word.Document

yol = ActiveWorkbook.Path & "\[COLOR="Red"]deneme.doc[/COLOR]"
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

ReDim veri(1000)

say9 = 0
For Each Picture In objWord.ActiveDocument.Shapes
say9 = say9 + 1
objWord.ActiveDocument.Shapes(say9).Select
veri(say9) = objWord.Selection.End
Next Picture

If say9 = 0 Then MsgBox "hiç resim nesnesi yok": GoTo atla

say9 = say9 + 1
veri(say9) = objWord.ActiveDocument.Range.End

For Each Picture In objWord.ActiveDocument.Shapes
i = i + 1
objWord.ActiveDocument.Shapes(i).Select
objWord.Selection.Copy

Set objWord2 = CreateObject("Word.Application")
objWord2.Visible = True
Set docWord2 = objWord2.Documents.Add(DocumentType:=wdNewBlankDocument)

objWord2.Selection.Paste

objWord2.Selection.TypeParagraph

objWord.ActiveDocument.Range(Start:=veri(i), End:=veri(i + 1)).Copy

objWord2.Selection.PasteSpecial Link:=False, DataType:=10
say10 = 0
For Each Picture2 In objWord2.ActiveDocument.Shapes
say10 = say10 + 1
objWord2.ActiveDocument.Shapes(say10).Top = 1
objWord2.ActiveDocument.Shapes(say10).Left = 1
Next Picture2


say5 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1

objWord2.ActiveDocument.SaveAs ThisWorkbook.Path & "\" & say5 & ".doc"
objWord2.ActiveDocument.Close
objWord2.Quit
Application.CutCopyMode = False


Next Picture

atla:
Application.DisplayAlerts = False
docWord.Close False
objWord.Quit

Set docWord = Nothing
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...
Hepinize teşekkürler.
Hepinize yardımınız için teşekkürler. Hepsini denedim karşılaştığım hataları belirttim.

halit3 Bey,
2. mesajda verdiğiniz kod için referans eklemeye çalıştım. Ama benim excelde "Microsoft Word 12.0 Object Library" değil "Microsoft Word 16.0 Object Library" onu seçtim

"Run-time 5174
Application -defined-or object defined error"

hatasını verdi

4. mesajdaki dosyları kopyaladım. deneme.doc word belgesi içine benim bölmek istediğim verileri kopyaladım. Çalıştırdım.

"Run-time 4608
Değer aralığı dışında"
hatası verdi.
Bir şeyi yanlış yaptım galiba hepsini silip yeniden yapayım dedim ama bu sefer de deneme.doc dosyasını silemiyorum.


Haluk Bey
3. mesajda gönderdiğiniz kodu yapıştırıp çalıştırdım. Aşağıdaki hatayı verdi.

"Run-time error 22147024809(80070057)
Belirlenen koleksiyonda olan dizin sınırlar dışında"

yine 5. mesajınızdaki kodu girdim yine aynı hatayı verdi.

"Run-time error 22147024809(80070057)
Belirlenen koleksiyonda olan dizin sınırlar dışında"


Sayın Leumruk
Gönderdiğiniz kod çalıştı ama bazı sorunlar var.
Şöyle ki benim word dosyamda resim dışında metin ve tablolar var. Sıralama şöyle resim metin altında boş tabo metin altında boş tablo... Sizin gönderdiğiniz kod metinleri boş kalması gereken tablonun içine yapıştırdı.

Hepinize tekrar teşekkürler.
 
Eneserhat' Alıntı:
Sayın Leumruk
Gönderdiğiniz kod çalıştı ama bazı sorunlar var.
Şöyle ki benim word dosyamda resim dışında metin ve tablolar var. Sıralama şöyle resim metin altında boş tabo metin altında boş tablo... Sizin gönderdiğiniz kod metinleri boş kalması gereken tablonun içine yapıştırdı.

Hepinize tekrar teşekkürler.
Genişletmek için tıkla ...

İçerisinde tablo olan, deneme yapabileceğim bir örnek ekler misiniz?
 
Hazirlanan kodlar, verdiginiz ornek dosyaya gore duzenlenmis ve test edilmistir. Gercek dosyanin yapisi farkliysa, o zaman biz bosuna ugrasmisiz.....!
Gercek dosyadan bir ornek eklemeniz gerekirdi....
 
Eneserhat' Alıntı:
Merhaba,

ekteki word dosyası gibi bir dosyayı 2 farklı word dosyası olarak kaydetmek mümkün mü? Her dosya üstteki resim ile başlayacak.

Üstten seçip bir sonraki resime kadar kopyalayıp yeni bir sayfaya yapışıtırıp dosyayı kaydediyorum. Ama çalıştığım dosyada 250 sayfa var ve her resim (antet) bir belgenin başlığı olacak.
Genişletmek için tıkla ...

.

250 sayfa 250 dosya olacak demek. Ne işe yarayacak? Eğer yapılmak istenen şey tam olarak açıklanırsa yani daha sizin yönlendirmeniz yerine, daha pratik ve kolay çözümler üretilebilir.

Değerli arkadaşlarımız uğraşarak bazı kodlar vermişler. Ancak istenilenin ne olduğu, ne olacağı tam olarak açıklanmadığı için sonuç almakta güçleştiği görülmektedir.



.
 
4 nolu mesaja kendi dosyanızı ve makronun bulunduğu dosyayı ekledim referansları yaptıysanız makrolarda etkin ise kod çalışıyor bu kodlar sizin örnek dosyanızda denenmiştir.
 
Boşa uğraştırmak gibi bir amacım yoktu.
Konu hakkında bilgisizliğimiz açmak zorunda olduğum konudan belli iken, alınganlık yapılması ilginç bir durum.

Ayrıca firma bilgilerini paylaşmamak adına konuyu anlatabileceğimi sandığım bir metin ve resim dosyası seçmiştim.
Çalıştığım dosyaya en yakın örnek dosya ektedir.
 

Ekli dosyalar

Resimlerin sabit bir konumu yok mu? Örneğin sayfa başında olmaları farklı bir kodlama, karışık düzende olmaları farklı bir kodlama gerektirir.
 
Kod: 
Sub makro3()
say = ActiveDocument.Shapes.Count
Set wd = CreateObject("Word.Application")
wd.Visible = False
Set yenidoc = wd.Documents.Add(DocumentType:=0)

son = ActiveDocument.Paragraphs.Count
For x = ActiveDocument.Shapes.Count To 1 Step -1
ilk = ActiveDocument.Range(0, ActiveDocument.Shapes(x).Anchor.End).Paragraphs.Count
ActiveDocument.Range(Paragraphs(ilk).Range.Start, Paragraphs(son).Range.End).Copy
wd.Selection.Paste

[B][COLOR="DarkRed"]For y = wd.ActiveDocument.Paragraphs.Count To 1 Step -1
k = wd.ActiveDocument.Paragraphs(y).Range.ComputeStatistics(Statistic:=3)
If k = 0 Then
wd.ActiveDocument.Paragraphs(y).Range.Delete
Else
Exit For
End If
Next[/COLOR][/B]

wd.ActiveDocument.SaveAs (ActiveDocument.Path & "\" & say & ".doc")
wd.ActiveDocument.Close False
If x = 1 Then wd.Application.Quit
If x <> 1 Then Set yenidoc = wd.Documents.Add(DocumentType:=0)
say = say - 1
son = ilk - 1
Next

MsgBox "İşlem tamamlandı.", vbOKOnly, "l e u m r u k"
End Sub

DÜZELTME: Kod yeniden düzenlendi. Kodların arasına sondaki boş sayfaları silmesi için kod ekledim. Hızı biraz düşürebilir. Dilerseniz bu kısmı silebilirsiniz. Kırmızı ile belirtiyorum.
 
Benim yazdığım kod dosyaları bu şekilde kayıt yaptı
 

Ekli dosyalar

Ben kendi kodumu, gönderdiğiniz dosyaya ekledim ve çalıştırdım. Hiç bir sıkıntı olmadı.

Sayfanın en üstüne bir buton yerleştirdim. Makroları etkinleştirdikten sonra, butona basıp çalıştırabilirsiniz.


.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst