Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Windows-Word-PowerPoint.... (http://www.excel.web.tr/forumdisplay.php?f=51)
-   -   100 Sayfalık Word Dosyasını Resime Göre Ayırmak (http://www.excel.web.tr/showthread.php?t=166860)

Eneserhat 22-09-2017 14:02

100 Sayfalık Word Dosyasını Resime Göre Ayırmak
 
1 Eklenti(ler)
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.

halit3 22-09-2017 23:28

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


Haluk 24-09-2017 00:47

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,


.

halit3 24-09-2017 19:31

2 Eklenti(ler)
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


Haluk 24-09-2017 21:03

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


leumruk 24-09-2017 23:31

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


Eneserhat 25-09-2017 09:32

Alıntı:

halit3 tarafından gönderildi (Mesaj 910233)
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


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.

leumruk 25-09-2017 09:50

Alıntı:

Eneserhat tarafından gönderildi (Mesaj 910476)
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.

İçerisinde tablo olan, deneme yapabileceğim bir örnek ekler misiniz?

Haluk 25-09-2017 10:02

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....

İdris SERDAR 25-09-2017 10:56

Alıntı:

Eneserhat tarafından gönderildi (Mesaj 910136)
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.

.

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.



.


Saat 03:21

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.