Çözüldü Word birleştirmek

[k0081]

Merhaba arkadaşlar ;

Bir klasörün içinde 13 adet word dosyası var. (.doc )

İlk dosyayı açıp diğer , 12 dosyayı makro ile nasıl ekleyebilirim ?

 

[Haluk]

Aşağıdaki linkte bu işi yapan VBA kodu var ...

https://www.extendoffice.com/documents/word/969-word-merge-multiple-documents.html

.

 

[k0081]

Aşağıdaki linkte bu işi yapan VBA kodu var ...

https://www.extendoffice.com/documents/word/969-word-merge-multiple-documents.html

.

Haluk bey;

VBA kodunu sayfaya ekleyip çalıştırdım. Ama dosyaların hepsini tek sayfada üst üste bindirerek birleştirdi. word dosyası tek olacak , ama sayfalarada kendi içinde tek olması gerekiyor.

Teşekkürler.

 

[Haluk]

Olayı tam olarak anlayamadım ama aşağıdaki kodu dener misiniz?

Sub MergeDocuments_HD()
    'Haluk - 17/02/2019
    'sa4truss@gmail.com
    '
    Application.ScreenUpdating = False
        MyPath = ActiveDocument.Path
        MyName = Dir(MyPath & "\" & "*.docx")
        i = 0
        Do While MyName <> ""
            If MyName <> ActiveDocument.Name Then
                Set wb = Documents.Open(MyPath & "\" & MyName)
                Selection.WholeStory
                Selection.Copy
                ThisDocument.Activate
                Selection.EndKey Unit:=wdLine
                Selection.TypeParagraph
                Selection.Paste
                Selection.InsertBreak Type:=wdPageBreak
                i = i + 1
                wb.Close False
            End If
            MyName = Dir
        Loop
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

.

 

[k0081]

Haluk;

Hocam bu kodda hata aldım. ( makro satırı : Selection.EndKey Unit:=wdLine )

Şimdi şöyle, bir word dosyasını açıp, diğerlerinide ark arkaya eklemek... bir önceki kod bunu yapıyor ama., tek bir word dosyası üstüne ekliyor.

yani bir sayfa görünüyor. ama altında bir kaç dosya var.

bir de şöyle bir durum var; bazı dosyalarda sadece resim verisi var. işte bunlar üst üste biniyor.

 

[leumruk]

Selamlar,
Alternatif olarak yapmış olduğum bir çalışmayı ekliyorum.

Sub Dosya_Birlestir()
yol = ActiveDocument.Path
ChangeFileOpenDirectory yol & "\"
Dosya = Dir(yol & "\*doc*")
Do While Dosya <> ""
If Dosya <> ActiveDocument.Name Then
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
Selection.InsertFile FileName:=Dosya
End If
Dosya = Dir
Loop
MsgBox "İşlem tamamlanmıştır.", vbOKOnly, "l e u m r u k"
End Sub

 

[k0081]

leumruk

Makro çalışmadı.

Düzenle dediğimde aldığım hata iletisi;

http://s7.dosya.tc/server13/dcrdjk/2019-02-17_145517.jpg.html

 

[halit3]

Bir alternatif kod da ben ekliyorum
Kodu excel dosyasındaki bir modüle ekleyip çalıştırın.

Sub deneme1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")


i = 0
'On Error Resume Next
For Each Dosya In fL.GetFolder(Kaynak).Files
If LCase(fL.GetExtensionName(Dosya)) = "doc" Or LCase(fL.GetExtensionName(Dosya)) = "docx" Then

i = i + 1

If i = 1 Then
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True
End If

yer = Dosya

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=yer, ReadOnly:=False)

objWord.ActiveDocument.Range.Copy

say5 = wrdApp.ActiveDocument.Bookmarks("\startOfSel").End
say2 = wrdApp.ActiveDocument.Range.End

wrdApp.Selection.Paste
say3 = wrdDoc.Range.Paragraphs.Count
wrdDoc.Paragraphs(say3).Range.Select

For k = 1 To 30
If i + 1 = wrdDoc.Range.Information(1) Then GoTo atla2
wrdApp.Selection.TypeParagraph
Next k
atla2:

docWord.Close
objWord.Quit SaveChanges:=wdSaveChanges

Set objWord = Nothing
Set docWord = Nothing

End If
Next

say = wrdDoc.Range.Paragraphs.Count
If Len(wrdDoc.Paragraphs(say).Range) <= 1 Then
wrdDoc.Paragraphs(say).Range.Delete
End If

Application.DisplayAlerts = False

sat1 = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\word dosya" & " " & sat1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdDoc.Close
wrdApp.Quit SaveChanges:=wdSaveChanges

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[k0081]

Halit;

Hocam çok teşekkürler, Tamamdır... elinize sağlık.

 

[leumruk]

leumruk

Makro çalışmadı.

Düzenle dediğimde aldığım hata iletisi;

Eğer kodları Word dosyasında çalıştırmışsanız hata almanızı gerektirecek bir durum yok. Referanslarla ilgili bir hata almışsınız. VBE editöründe Toolls>References bölümünü açın. Missing yazan bir referans varsa tikini kaldırıp deneyiniz.

 

[k0081]

Eğer kodları Word dosyasında çalıştırmışsanız hata almanızı gerektirecek bir durum yok. Referanslarla ilgili bir hata almışsınız. VBE editöründe Toolls>References bölümünü açın. Missing yazan bir referans varsa tikini kaldırıp deneyiniz.

Evet wordde çalıştırmıştım. Ama makro kodu çalışmıyor. Referanslarla ilgili bir durum değil bence...

 

[leumruk]

Hangi satırda hata gösteriyor?

 

[k0081]

Hangi satırda hata gösteriyor?

Hocam; makro çalıştır a tıkladığımda hiç bir hata vermiyor. Öyle kalıyor. Bi önceki mesajda verdiğim hata iletisini makroyu düzenle dediğimde aldım.

 

[leumruk]

Makro kaydet yöntemiyle bir makro satırı elde edip, benim kodlarımı onun içine kopyalayarak dener misiniz

 

[k0081]

Hocam ; çok teşekkür ediyorum, Tamamdır. Bu haliyle çok kullanışlı oldu. Elinize sağlık hocam

Not : Aynı olayı JPG dosyaları için de uygulayabilir miyiz sizin kod üzerinden bir deneyeceğim. Yani yine word dosyası üzerinde işlem yapacak ama , bu sefer jpg dosyalarını ekleyecek.

 

[leumruk]

Hocam ; çok teşekkür ediyorum, Tamamdır. Bu haliyle çok kullanışlı oldu. Elinize sağlık hocam

Not : Aynı olayı JPG dosyaları için de uygulayabilir miyiz sizin kod üzerinden bir deneyeceğim. Yani yine word dosyası üzerinde işlem yapacak ama , bu sefer jpg dosyalarını ekleyecek.

Selamlar,
Resim için hazırlamış olduğum aşağıdaki kodlamayı kullanabilirsiniz.

Sub Makro2()
yol = ActiveDocument.Path
ChangeFileOpenDirectory yol & "\"
Dosya = Dir(yol & "\*jpg")
Do While Dosya <> ""
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
Selection.InlineShapes.AddPicture FileName:=Dosya
Dosya = Dir
Loop
MsgBox "İşlem tamamlanmıştır.", vbOKOnly, "l e u m r u k"
End Sub

 

[k0081]

leumruk;

Hocam çok teşekkürler, tamamdır elinize sağlık.. araya boş sayfa da ekliyor ama, çok da sorun değil.

Süper bi çalışma oldu.. Saygılar.

 

[halit3]

Hocam ; çok teşekkür ediyorum, Tamamdır. Bu haliyle çok kullanışlı oldu. Elinize sağlık hocam

Not : Aynı olayı JPG dosyaları için de uygulayabilir miyiz sizin kod üzerinden bir deneyeceğim. Yani yine word dosyası üzerinde işlem yapacak ama , bu sefer jpg dosyalarını ekleyecek.

Bu konular evvelce burada işlendi Alternatif kod
https://www.excel.web.tr/threads/makro-ile-word-dosyasina-klasoerdeki-resimleri-eklemek.163908/

Dim klasor2(50000)
Dim saydır


Sub deneme2()


Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

saydır = 0
Liste5 (Kaynak)

Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


yol = ThisWorkbook.Path & "\"
sayi = Application.InputBox("Kaç adet sütun eklenecek.", "Sayı giriniz.", "2", 400, 30, , Type:=1)
   
If sayi = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

msg1 = MsgBox("Sayfayı DİKEY yapmak için  EVET  tıklayınız. " & Chr(10) & Chr(10) & _
"Sayfayı YATAY yapmak için  HAYIR  tıklayınız.", vbYesNo + vbInformation, "u y a r ı !")


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add ' create a new document
wrdApp.Visible = False
With wrdDoc
.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 15 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 15 'üst
.BottomMargin = 10 '20 ' alt

If msg1 = vbYes Then
.Orientation = wdOrientPortrait
yükseylik = 189
Else
.Orientation = wdOrientLandscape
yükseylik = 175
End If

End With

With wrdApp.ActiveDocument

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
wrdApp.ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, NumColumns:=sayi

With wrdApp.ActiveDocument.Tables(1)
If .Style <> "Tablo Kılavuzu" Then
.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
End With

ekle1 = 0
sat = 0
Say = 0

For i = 1 To saydır

For Each Dosya In fL.GetFolder(klasor2(i)).Files

If LCase(fL.GetExtensionName(Dosya)) = "jpg" Or LCase(fL.GetExtensionName(Dosya)) = "bmp" Then
Say = Say + 1
If Say Mod sayi = 1 Then
sut = 1
sat = sat + 1 + ekle1
ekle1 = 1
son = wrdApp.ActiveDocument.Tables(1).Rows.Count ' satır kontrol

If wrdApp.ActiveDocument.Tables.Count >= 1 Then
If Say > 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
End If

Else
sut = sut + 1
End If


With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat + 1, sut)
.Range = fL.GetBaseName(Dosya)
End With

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat, sut)
.Range.Paragraphs.WordWrap = True
.Range.InlineShapes.AddPicture Filename:=Dosya, LinkToFile:=False, SaveWithDocument:=True
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yükseylik '189 '200
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6 '285 '250
End With

End If
Next
Next

End With

son1 = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
End With

wrdApp.Documents(wrdDoc.Name).Activate
wrdApp.Visible = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

Private Sub Liste5(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

saydır = saydır + 1
klasor2(saydır) = yol
'MsgBox yol
sonraki:
For Each f In fL.GetFolder(yol).subfolders
Liste5 (f.Path)
On Error GoTo sonraki
Next

End Sub

 

[k0081]

Halit ;

Doğrudur hocam, ben konuyu bulup kod üzerinde değişiklik yapmam zor olabilirdi. ,,

Yeri gelmişken excel üzerindende yapılmasında farklı bir format oldu...

Son olarak 1 sorum daha var size;
Göndermiş olduğunuz kodda hangi kodları değiştirir yada eklersem "jpg" dosyalarını ekler ?
Teşekkürler, Saygılar.

 

[halit3]

zaten jpg dosyalarını ekliyor birde bmp dosyalarını da ekliyor

If LCase(fL.GetExtensionName(Dosya)) = "jpg" Or LCase(fL.GetExtensionName(Dosya)) = "bmp" Then