birden fazla word dosyasını tek sayfada toplama

[erdenek]

arkadaşlar bu 4 adet word dosyasını tek word dosyasında tablo halinde nasıl yapabilirim?

 

[muhasebeciyiz]

Dört farklı Word dosyasını tek bir tablo halinde birleştirmek için en kolay ve en pratik yöntem, içeriği kopyalayıp yapıştırmaktır.

1. Yeni bir Word dosyası açın.
2. İlk dosyanızdaki tabloyu veya metinleri seçin ve kopyalayın.
3. Yeni açtığınız dosyaya yapıştırın.
4. Diğer üç dosya için de aynı işlemi tekrarlayın.

Bu yöntemle tüm görev dağılımı listelerinizi tek bir dosya içinde kolayca bir araya getirebilirsiniz. Eğer dört farklı listenin hepsini tek bir tabloda görmek istiyorsanız, öncelikle yeni bir Word dosyasına bir tablo ekleyin. Ardından, her bir dosyadaki içeriği bu tablonun ilgili hücrelerine kopyalayıp yapıştırabilirsiniz.

 

[muhasebeciyiz]

1. Yeni bir Word dosyası oluştur

Word programını aç.
Boş bir belge oluştur.

2. Tabloyu ekle

Menüden Ekle > Tablo seçeneğine tıkla.
2 sütun ve 4 satırdan oluşan bir tablo ekle (dosya sayısına göre satır sayısını ayarla).
Örnek: Sol sütun "Dosya Adı", sağ sütun "İçerik".

3. Her dosyanın içeriğini kopyala

Her bir Word dosyasını ayrı ayrı aç.
Tüm içeriği seçmek için Ctrl + A, ardından kopyalamak için Ctrl + C tuşlarına bas.
Yeni oluşturduğun tabloda ilgili hücreye Ctrl + V ile yapıştır.
4. Görsel düzenlemeleri yap

Hücre boyutlarını ayarla (içerik sığmıyorsa hücreyi genişlet).
Gerekirse metin biçimlendirmesi (başlık, kalın yazı, renk vs.) uygula.
Tablo kenarlıklarını görünür veya gizli hale getirebilirsin.

5. Dosyayı kaydet

Dosyayı istediğin isimle .docx formatında kaydet.

 

[muhasebeciyiz]

Sub KlasordekiWordDosyalariniTekSayfadaBirlestir()
    Dim dlg As FileDialog
    Dim klasorYolu As String
    Dim dosyaAdı As String
    Dim anaDoc As Document
    Dim eklenecekDoc As Document
    Dim docRange As Range
   
    Set anaDoc = Documents.Add
   
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    With dlg
        .Title = "Word dosyalarının bulunduğu klasörü seçin"
        If .Show <> -1 Then
            MsgBox "İşlem iptal edildi.", vbExclamation
            Exit Sub
        End If
        klasorYolu = .SelectedItems(1)
        If Right(klasorYolu, 1) <> "\" Then
            klasorYolu = klasorYolu & "\"
        End If
    End With
   
    dosyaAdı = Dir(klasorYolu & "*.docx")

    Do While dosyaAdı <> ""
        Dim tamYol As String
        tamYol = klasorYolu & dosyaAdı
       
        Set eklenecekDoc = Documents.Open(FileName:=tamYol, ReadOnly:=True)
       
        Set docRange = anaDoc.Content
        docRange.Collapse Direction:=wdCollapseEnd
       
        eklenecekDoc.Content.Copy
        docRange.Paste
       
        docRange.InsertAfter vbCrLf & vbCrLf
     
        eklenecekDoc.Close SaveChanges:=False
     
        dosyaAdı = Dir
    Loop

    MsgBox "Tüm dosyalar başarıyla birleştirildi.", vbInformation
End Sub

Masaüstüne okul diye klasör aç 4 dosyayı buraya kopyalayınız

• Boş olan yeni bir word dosyası aç.
• Alt + F11 tuşlarına basarak VBA editörünü aç.
• Menüden Insert > Module seç.
• Yukarıdaki kodu yapıştır:

 

[erdenek]

üstad yapamadım.Geliştirici > Makrolar > Yeni (yeni kısmını bulamadım.)

 

[halit3]

kod ve dosya

Sub word_birlestir()

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 Left(Dosya.Name, 2) = "~$" Then GoTo atla1

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

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
atla1:
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

 

[erdenek]

teşekkür ederim üstad