Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > Diğer Yazılımlar > Windows-Word-PowerPoint....
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Windows-Word-PowerPoint.... Excel haricindeki Ofis programları ile ilgili konular.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 22-09-2017, 14:02   #1
Eneserhat
Altın Üye
 
Giriş: 16/09/2011
Şehir: İstanbul
Mesaj: 26
Excel Vers. ve Dili:
Microsoft Office 2016
Varsayılan 100 Sayfalık Word Dosyasını Resime Göre Ayırmak

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.
Eklenmiş Dosyalar
Dosya Türü: doc Atatürk Özlü Sözler.doc (58.5 KB, 13 Görüntülenme)
Eneserhat Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-09-2017, 23:28   #2
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,482
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Microsoft Word 12.0 Object Library
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 24-09-2017, 00:47   #3
Haluk
Özel Üye
 
Giriş: 07/07/2004
Şehir: Türkiye
Mesaj: 5,080
Excel Vers. ve Dili:
Office 2010 - İngilizce
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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,


.
__________________
Kod anlatılmaz,yazılır !

Bu mesaj en son " 24-09-2017 " tarihinde saat 01:02 itibariyle Haluk tarafından düzenlenmiştir....
Haluk Çevrimdışı   Alıntı Yaparak Cevapla
Eski 24-09-2017, 19:31   #4
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,482
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Bu kod da birazcık forklı

Referanslardan bu olmalı

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Microsoft Word 12.0 Object Library
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
Eklenmiş Dosyalar
Dosya Türü: xls Yeni Microsoft Excel Çalışma Sayfası.xls (33.0 KB, 4 Görüntülenme)
Dosya Türü: doc deneme.doc (58.5 KB, 2 Görüntülenme)
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 24-09-2017, 21:03   #5
Haluk
Özel Üye
 
Giriş: 07/07/2004
Şehir: Türkiye
Mesaj: 5,080
Excel Vers. ve Dili:
Office 2010 - İngilizce
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
Kod anlatılmaz,yazılır !

Bu mesaj en son " 24-09-2017 " tarihinde saat 21:12 itibariyle Haluk tarafından düzenlenmiştir....
Haluk Çevrimdışı   Alıntı Yaparak Cevapla
Eski 24-09-2017, 23:31   #6
leumruk
Uzman
 
leumruk kullanıcısının avatarı
 
Giriş: 15/04/2007
Şehir: Mustafa ALTUN ANKARA
Mesaj: 3,163
Excel Vers. ve Dili:
Office 2010 & 2013 tr
Varsayılan

Merhaba,
Bir alternatif de ben ekleyeyim. Makro word üzerinde düzenlenmiştir.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
"Seni her türlü noksandan tenzih ederiz. Senin bize öğrettiğinden başka bizim hiçbir bilgimiz yoktur. Sen herşeyi hakkıyla bilir, her işi hikmetle yaparsın." (Bakara Sûresi: 2:32.)

"Onların duaları şu sözlerle sona erer: Ezelden ebede her türlü hamd ve övgü, şükür ve minnet, Âlemlerin Rabbi olan Allah'a mahsustur." (Yunus Suresi, 10:10.)
leumruk Çevrimdışı   Alıntı Yaparak Cevapla
Eski 25-09-2017, 09:32   #7
Eneserhat
Altın Üye
 
Giriş: 16/09/2011
Şehir: İstanbul
Mesaj: 26
Excel Vers. ve Dili:
Microsoft Office 2016
Varsayılan

Alıntı:
halit3 tarafından gönderildi Mesajı Görüntüle
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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Microsoft Word 12.0 Object Library
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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.
Eneserhat Çevrimdışı   Alıntı Yaparak Cevapla
Eski 25-09-2017, 09:50   #8
leumruk
Uzman
 
leumruk kullanıcısının avatarı
 
Giriş: 15/04/2007
Şehir: Mustafa ALTUN ANKARA
Mesaj: 3,163
Excel Vers. ve Dili:
Office 2010 & 2013 tr
Varsayılan

Alıntı:
Eneserhat tarafından gönderildi Mesajı Görüntüle
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?
__________________
"Seni her türlü noksandan tenzih ederiz. Senin bize öğrettiğinden başka bizim hiçbir bilgimiz yoktur. Sen herşeyi hakkıyla bilir, her işi hikmetle yaparsın." (Bakara Sûresi: 2:32.)

"Onların duaları şu sözlerle sona erer: Ezelden ebede her türlü hamd ve övgü, şükür ve minnet, Âlemlerin Rabbi olan Allah'a mahsustur." (Yunus Suresi, 10:10.)
leumruk Çevrimdışı   Alıntı Yaparak Cevapla
Eski 25-09-2017, 10:02   #9
Haluk
Özel Üye
 
Giriş: 07/07/2004
Şehir: Türkiye
Mesaj: 5,080
Excel Vers. ve Dili:
Office 2010 - İngilizce
Varsayılan

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....
__________________
Kod anlatılmaz,yazılır !
Haluk Çevrimdışı   Alıntı Yaparak Cevapla
Eski 25-09-2017, 10:56   #10
İdris SERDAR
Moderatör
 
İdris SERDAR kullanıcısının avatarı
 
Giriş: 21/10/2005
Şehir: Ankara
Mesaj: 14,418
Excel Vers. ve Dili:
Excel, 2016 - İngilizce
Varsayılan

Alıntı:
Eneserhat tarafından gönderildi Mesajı Görüntüle
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.



.
__________________
Çalışmalarımı görmek için:

http://www.excelgurusu.com/

İdris SERDAR
İdris SERDAR Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 03:00


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden