Excel tablosunu Word tablosuna aktarmak

[hadromer]

Merhaba,
Excel'de yer alan ders programı tablosunu, farklı bir düzende yer alan word dosyası içerisindeki tabloya aktarmak istiyorum. Excel formatında ki "eski" adlı dosyada solda saatler ve üst satırda günler yer alıyor.

Yeni adlı dosyada ise solda günler üstte saatler yer alacak. Eski adlı dosyada Dersin adı, dersin hocası ve derslik bilgileri ayrı hücrelere bölünmüş. Ben manuel olarak dönüştürme yaptığımda çok uğraştırıyor. Hazırlamam gereken 12 ayrı sınıfın programı olduğu için çok zamanımı alacak. Bu dönüşüm için ne yapabiliriz ? VBA kodu istediğimizi yapabilir mi? Teşekkür ederim şimdiden.

 

[necati]

Merhaba,
Dosyaları harici link olarak da paylaşabilir misiniz?

 

[hadromer]

Merhaba,
Dosyaları harici link olarak da paylaşabilir misiniz?

merhaba,
dosyalar linktedir

DOSYALARI İNDİR

 

[necati]

Sadece word dosyası indirildi. Excel yoktu.

 

[hadromer]

Sadece word dosyası indirildi. Excel yoktu.

kusura bakmayın yanlış dosya yüklemişim. rar şeklinde yükledim buyrun : https://s6.dosya.tc/server21/zg2rwi/24-25_ders_programi_caliosmalari.rar.html

 

[necati]

Wordde bir günde 8 ders var, excelde ise 9 ders var. Bunların eşit sayıda olması gerekmiyor mu?
Ders saatlerinde 15 dakikalık bir fark var ama bunu önemsemiyoruz sanırım. Önemli olan ders adedinin tutması. Doğru mudur?

 

[hadromer]

Wordde bir günde 8 ders var, excelde ise 9 ders var. Bunların eşit sayıda olması gerekmiyor mu?
Ders saatlerinde 15 dakikalık bir fark var ama bunu önemsemiyoruz sanırım. Önemli olan ders adedinin tutması. Doğru mudur?

merhaba,
sınıflara göre veya döneme göre ders sayıları farklılık gösteriyor. örneğin 1.sınıf 8 ders var ise 2.sınıfta 12 ders olabiliyor. Bu detayı vermeyi unutmuşum haklısınız. ders saatlerindeki fark önemli değil evet. ders sayısı olarak değil de excel'de ne varsa word'e aktarsın şeklinde yapabilir miyiz ?

 

[necati]

Referanslardan Microsoft Word xx.0 Object Library aktif edelim.
Excel tablosunda ilk derse 2 satır ayrılmış, bunu diğerleri gibi 3 satır olarak ayarlayalım. Bu önemli. Çünkü worddeki ders tablosuna ekleme yapılması gerektiğini doğru tesbit etmemizi sağlıyacak. "ESKİ.xlsx" kitabına bu makroyu ekleyip "xlsm" uzantılı olarak kaydedin.
"YENİ.docx" belgesini şablon olarak kullanıyoruz. Dolayısıyla bunun paragraf ayarlarını, hücre hizalamasını düzgün yaparsanız oluşacak belge de düzgün görünecektir. Belgeniz aynı klasörde "A3" de yazan metinle adlandırılmış olarak oluşturuluyor.

Option Explicit
Sub MSWord_Ders_Programi()
Dim wrdApp As Object
Dim wrdDoc As Object
Dim ws As Worksheet, sablon As String
Dim i As Integer, j As Integer, k As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer

Set ws = ThisWorkbook.Sheets("Sayfa1")
sonsat = ActiveSheet.UsedRange.Rows.Count
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
Set wrdDoc = wrdApp.Documents.Add(sablon)
derssay = wrdDoc.Tables(1).Columns.Count - 1

If derssay < Int((sonsat - 5) / 3) Then
ekle = Int((sonsat - 5) / 3) - derssay
    For i = 1 To ekle
        wrdDoc.Tables(1).Columns.Add
    Next i
wrdDoc.Tables(1).Rows.Alignment = wdAlignRowCenter
MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
End If

For j = 2 To 6
    i = 5
    For k = 2 To Int((sonsat - 5) / 3) + 1
        If ws.Cells(i, j).MergeCells = False Then
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text & vbNewLine & _
            ws.Cells(i + 1, j).Text & vbNewLine & _
            ws.Cells(i + 2, j).Text
            i = i + 3
        Else
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text
            i = i + 3
        End If
    Next k
Next j
        
wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & 3).Text & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing

wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Belge hazırlandı", vbInformation
End Sub

 

[hadromer]

Referanslardan Microsoft Word xx.0 Object Library aktif edelim.
Excel tablosunda ilk derse 2 satır ayrılmış, bunu diğerleri gibi 3 satır olarak ayarlayalım. Bu önemli. Çünkü worddeki ders tablosuna ekleme yapılması gerektiğini doğru tesbit etmemizi sağlıyacak. "ESKİ.xlsx" kitabına bu makroyu ekleyip "xlsm" uzantılı olarak kaydedin.
"YENİ.docx" belgesini şablon olarak kullanıyoruz. Dolayısıyla bunun paragraf ayarlarını, hücre hizalamasını düzgün yaparsanız oluşacak belge de düzgün görünecektir. Belgeniz aynı klasörde "A3" de yazan metinle adlandırılmış olarak oluşturuluyor.

Option Explicit
Sub MSWord_Ders_Programi()
Dim wrdApp As Object
Dim wrdDoc As Object
Dim ws As Worksheet, sablon As String
Dim i As Integer, j As Integer, k As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer

Set ws = ThisWorkbook.Sheets("Sayfa1")
sonsat = ActiveSheet.UsedRange.Rows.Count
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
Set wrdDoc = wrdApp.Documents.Add(sablon)
derssay = wrdDoc.Tables(1).Columns.Count - 1

If derssay < Int((sonsat - 5) / 3) Then
ekle = Int((sonsat - 5) / 3) - derssay
    For i = 1 To ekle
        wrdDoc.Tables(1).Columns.Add
    Next i
wrdDoc.Tables(1).Rows.Alignment = wdAlignRowCenter
MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
End If

For j = 2 To 6
    i = 5
    For k = 2 To Int((sonsat - 5) / 3) + 1
        If ws.Cells(i, j).MergeCells = False Then
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text & vbNewLine & _
            ws.Cells(i + 1, j).Text & vbNewLine & _
            ws.Cells(i + 2, j).Text
            i = i + 3
        Else
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text
            i = i + 3
        End If
    Next k
Next j
       
wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & 3).Text & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing

wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Belge hazırlandı", vbInformation
End Sub

emeğinize sağlık, istediğim gibi çalışıyor. Teşekkür ederim

 

[necati]

Rica ederim. Kolay gelsin.

 

[hadromer]

Rica ederim. Kolay gelsin.

Necati bey merhaba yeniden.
kusura bakmayın bir soru sormak istiyorum. Ders adı, hoca adı ve derslik bilgilerini ekleyince yeni oluşan tablo pencerenin dışına taşıyor. Tabloyu üç sayfada oluşturuyor. saat bilgilerini içeren üst satır ilk sayfada kalıyor. ders adları ikinci sayfadan başlıyor. ben tablo genişliğini sabit tutmak için bazı düzenlemeler yapmak istedim ama başarılı olamadım. Bu konuda yardımcı olabilir misiniz ?

 

[hadromer]

Option Explicit
Sub MSWord_Ders_Programi()
    Dim wrdApp As Object ' Changed to Object for late binding
    Dim wrdDoc As Object ' Changed to Object for late binding
    Dim ws As Worksheet, sablon As String
    Dim i As Integer, j As Integer, k As Integer
    Dim sonsat As Integer, derssay As Integer, ekle As Integer

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    sonsat = ws.UsedRange.Rows.Count
    On Error GoTo 0 ' Recommended to turn off error resume after critical code

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

    sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
    Set wrdDoc = wrdApp.Documents.Add(sablon)
    derssay = wrdDoc.Tables(1).Columns.Count - 1

    ' Gerekirse yeni sütun ekleyin
    If derssay < Int((sonsat - 5) / 3) Then
        ekle = Int((sonsat - 5) / 3) - derssay
        For i = 1 To ekle
            wrdDoc.Tables(1).Columns.Add
        Next i
        MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
    End If

    ' Excel'deki verileri Word tablosuna kopyalayın
    For j = 2 To 6
        i = 5
        For k = 2 To Int((sonsat - 5) / 3) + 1
            If ws.Cells(i, j).MergeArea.Cells.Count = 1 Then
                wrdDoc.Tables(1).Cell(j, k).Range.Text = _
                ws.Cells(i, j).Text & vbNewLine & _
                ws.Cells(i + 1, j).Text & vbNewLine & _
                ws.Cells(i + 2, j).Text
                i = i + 3
            Else
                wrdDoc.Tables(1).Cell(j, k).Range.Text = _
                ws.Cells(i, j).Text
                i = i + 3
            End If
        Next k
    Next j
    
    ' Tabloyu sabitlemek ve taşmasını engellemek için ayarlar
    With wrdDoc.Tables(1)
        .AllowAutoFit = False ' Otomatik boyutlandırmayı devre dışı bırak
        
        ' Sütun genişliklerini manuel olarak ayarlayın (cm cinsinden)
        Dim colWidth As Single
        colWidth = 50 ' Sütun genişliği için 50 noktaya (yaklaşık 1.76 cm) ayarlayın
        For i = 1 To .Columns.Count
            .Columns(i).Width = colWidth
        Next i

        ' Tablonun sabit bir yerde kalması için metin hizalaması ve boşluk ayarları
        Dim cell As Object ' Changed to Object for late binding
        For Each cell In .Range.Cells
            cell.Range.ParagraphFormat.SpaceAfter = 0 ' Paragraf sonrası boşluk bırakma
            cell.Range.ParagraphFormat.SpaceBefore = 0 ' Paragraf öncesi boşluk bırakma
            cell.Range.ParagraphFormat.Alignment = 1 ' Metni ortalayın
            cell.VerticalAlignment = 1 ' Dikey hizalama
        Next cell
    End With
    
    ' Belgeyi kaydedin ve kapatın
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & ws.Range("A3").Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belge hazırlandı", vbInformation
End Sub

bu kod ile pencereyi sabitlemeyi başardım. sizden ricam tekrar eden veriler iki hücreye yazılıyor. tekrar eden verileri hücreleri birleştirip teke düşürsün. bu kod konusunda yardımcı olabilir misiniz ?

 

[necati]

İsterseniz kodları değiştirmeden önce yapılabilecek olanları yaptıktan sonra kodları değiştirelim.
1- Şablon olarak kullandığımız dosyada sayfa kenar boşluklarını minimum yaptık mı?
2- Hücre içi paragraf ayarlarında, önce ve sonra üstte ve altta bırakılacak boşlukları minimum yaptık mı?
3- Bunlar yapıldığı halde yine taşma varsa o zaman şu satırı makromuza ilave edelim.
wrdDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)

Option Explicit
Sub MSWord_Ders_Programi2()
Dim wrdApp As Object
Dim wrdDoc As Object
Dim ws As Worksheet, sablon As String
Dim i As Integer, j As Integer, k As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer

Set ws = ThisWorkbook.Sheets("Sayfa1")
sonsat = ActiveSheet.UsedRange.Rows.Count
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
Set wrdDoc = wrdApp.Documents.Add(sablon)
derssay = wrdDoc.Tables(1).Columns.Count - 1

If derssay < Int((sonsat - 5) / 3) Then
ekle = Int((sonsat - 5) / 3) - derssay
    For i = 1 To ekle
        wrdDoc.Tables(1).Columns.Add
    Next i
wrdDoc.Tables(1).Rows.Alignment = wdAlignRowCenter
MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
End If

For j = 2 To 6
    i = 5
    For k = 2 To Int((sonsat - 5) / 3) + 1
        If ws.Cells(i, j).MergeCells = False Then
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text & vbNewLine & _
            ws.Cells(i + 1, j).Text & vbNewLine & _
            ws.Cells(i + 2, j).Text
            i = i + 3
        Else
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text
            i = i + 3
        End If
    Next k
Next j

wrdDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)
       
wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & 3).Text & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing

wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Belge hazırlandı", vbInformation
End Sub

 

[hadromer]

İsterseniz kodları değiştirmeden önce yapılabilecek olanları yaptıktan sonra kodları değiştirelim.
1- Şablon olarak kullandığımız dosyada sayfa kenar boşluklarını minimum yaptık mı?
2- Hücre içi paragraf ayarlarında, önce ve sonra üstte ve altta bırakılacak boşlukları minimum yaptık mı?
3- Bunlar yapıldığı halde yine taşma varsa o zaman şu satırı makromuza ilave edelim.
wrdDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)

Option Explicit
Sub MSWord_Ders_Programi2()
Dim wrdApp As Object
Dim wrdDoc As Object
Dim ws As Worksheet, sablon As String
Dim i As Integer, j As Integer, k As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer

Set ws = ThisWorkbook.Sheets("Sayfa1")
sonsat = ActiveSheet.UsedRange.Rows.Count
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
Set wrdDoc = wrdApp.Documents.Add(sablon)
derssay = wrdDoc.Tables(1).Columns.Count - 1

If derssay < Int((sonsat - 5) / 3) Then
ekle = Int((sonsat - 5) / 3) - derssay
    For i = 1 To ekle
        wrdDoc.Tables(1).Columns.Add
    Next i
wrdDoc.Tables(1).Rows.Alignment = wdAlignRowCenter
MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
End If

For j = 2 To 6
    i = 5
    For k = 2 To Int((sonsat - 5) / 3) + 1
        If ws.Cells(i, j).MergeCells = False Then
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text & vbNewLine & _
            ws.Cells(i + 1, j).Text & vbNewLine & _
            ws.Cells(i + 2, j).Text
            i = i + 3
        Else
            wrdDoc.Tables(1).Cell(j, k).Range.Text = _
            ws.Cells(i, j).Text
            i = i + 3
        End If
    Next k
Next j

wrdDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)
      
wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & 3).Text & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing

wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Belge hazırlandı", vbInformation
End Sub

Hocam teşekkürler geri dönüşünüz için.
kodu uyguladığımda "wdAlignRowCenter" kısmı için variable not defined hatası alıyorum. bunu 1 olarak değiştirdiğimde aynı hatayı (wdAutoFitWindow) kısmı için alıyorum

 

[necati]

Referanslardaki Microsoft Word xx.0 Object Library kutusundaki onayı kaldırdınız mı? O yüzden veriyor galiba.

 

[hadromer]

Referanslardaki Microsoft Word xx.0 Object Library kutusundaki onayı kaldırdınız mı? O yüzden veriyor galiba.

hayır referanslardaki word kutucuğu aktif.
hocam aşağıdaki kodu uygulayınca tablo kaymıyor. Kodu kontrol eder misiniz ? sizi, daha fazla yormak istemiyorum. hücre birleştirme ve tekrar eden dersi tek olarak birleşen hücreye yazsa çok mutlu olurum

Option Explicit
Sub MSWord_Ders_Programi()
    Dim wrdApp As Object ' Changed to Object for late binding
    Dim wrdDoc As Object ' Changed to Object for late binding
    Dim ws As Worksheet, sablon As String
    Dim i As Integer, j As Integer, k As Integer
    Dim sonsat As Integer, derssay As Integer, ekle As Integer
    Dim tbl As Object ' Changed to Object for late binding

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    sonsat = ws.UsedRange.Rows.Count
    On Error GoTo 0 ' Recommended to turn off error resume after critical code

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

    sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
    Set wrdDoc = wrdApp.Documents.Add(sablon)
    Set tbl = wrdDoc.Tables(1)
    derssay = tbl.Columns.Count - 1

    ' Gerekirse yeni sütun ekleyin
    If derssay < Int((sonsat - 5) / 3) Then
        ekle = Int((sonsat - 5) / 3) - derssay
        For i = 1 To ekle
            tbl.Columns.Add
        Next i
        MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
    End If

    ' Excel'deki verileri Word tablosuna kopyalayın
    For j = 2 To 6
        i = 5
        For k = 2 To Int((sonsat - 5) / 3) + 1
            If ws.Cells(i, j).MergeArea.Cells.Count = 1 Then
                tbl.cell(j, k).Range.Text = _
                ws.Cells(i, j).Text & vbNewLine & _
                ws.Cells(i + 1, j).Text & vbNewLine & _
                ws.Cells(i + 2, j).Text
                i = i + 3
            Else
                tbl.cell(j, k).Range.Text = _
                ws.Cells(i, j).Text
                i = i + 3
            End If
        Next k
    Next j

    ' Tabloyu sabitlemek ve taşmasını engellemek için ayarlar
    With tbl
        .AllowAutoFit = True ' Otomatik boyutlandırmayı etkinleştir
        
        ' Tablonun pencereye sığmasını sağlamak için tablo genişliğini ayarlayın
        .PreferredWidthType = 2 ' Yüzde olarak genişlik
        .PreferredWidth = 100 ' %100 genişlik

        ' Sütun genişliklerini manuel olarak ayarlayın (cm cinsinden)
        Dim colWidth As Single
        colWidth = .Range.PageWidth / .Columns.Count ' Sütun genişliğini pencere genişliğine göre ayarla
        For i = 1 To .Columns.Count
            .Columns(i).Width = colWidth
        Next i

        ' Tablonun sabit bir yerde kalması için metin hizalaması ve boşluk ayarları
        Dim cell As Object ' Changed to Object for late binding
        For Each cell In .Range.Cells
            cell.Range.ParagraphFormat.SpaceAfter = 0 ' Paragraf sonrası boşluk bırakma
            cell.Range.ParagraphFormat.SpaceBefore = 0 ' Paragraf öncesi boşluk bırakma
            cell.Range.ParagraphFormat.Alignment = 1 ' Metni ortalayın
            cell.VerticalAlignment = 1 ' Dikey hizalama
        Next cell
    End With
    
    ' Tekrar eden hücreleri birleştirin
    Dim r As Integer, c As Integer
    For r = 1 To tbl.Rows.Count
        For c = 1 To tbl.Columns.Count
            If tbl.cell(r, c).Range.Text = Chr(7) & Chr(7) Then
                tbl.cell(r, c).Merge MergeTo:=tbl.cell(r, c).Range.Cells(tbl.Rows.Count, tbl.Columns.Count)
            End If
        Next c
    Next r

    ' Belgeyi kaydedin ve kapatın
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & ws.Range("A3").Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belge hazırlandı", vbInformation
End Sub

 

[necati]

Benim 13. mesajdaki 2 tavsiyemi şablon sayfasında bir defalığına manuel olarak yapınca kod içine eklediğiniz satırlara gerek kalmıyor. Ama siz bu şekilde yapmak istiyorsanız bunlar da uygun. Ben "hücre birleştirme ve tekrar eden ders" ifadesini anlayamadım. Örnek olarak paylaşırsanız (hatalı halini ve olmasını istediğiniz halini) ben de bakıp anlamaya çalışayım.

 

[hadromer]

Benim 13. mesajdaki 2 tavsiyemi şablon sayfasında bir defalığına manuel olarak yapınca kod içine eklediğiniz satırlara gerek kalmıyor. Ama siz bu şekilde yapmak istiyorsanız bunlar da uygun. Ben "hücre birleştirme ve tekrar eden ders" ifadesini anlayamadım. Örnek olarak paylaşırsanız (hatalı halini ve olmasını istediğiniz halini) ben de bakıp anlamaya çalışayım.

hocam 13. mesajdaki 2. tavsiyenizi uyguladım ancak ders adları uzun olduğu için sanırım ilk satırdaki dersleri dikey yazdı

buyrun hocam hatalı ve doğru olmak üzere iki word dosyası içeren arşiv linki :

İndir TABLO

Dosyayı indir TABLO

dosya.co

 

[necati]

hocam 13. mesajdaki 2. tavsiyenizi uyguladım ancak ders adları uzun olduğu için sanırım ilk satırdaki dersleri dikey yazdı

Tam da demek istediğim bu işte. (Dikey durumu). Tekrar altını çizerek yazıyorum, o dikey yazılar paragraf ayarında girinti fazlalığından kaynaklanıyor.
"Yeni.docx" de tabloda hücre içi paragraf ayarlarında, önce ve sonra üstte ve altta bırakılacak boşlukları minimum yaptık mı?

EK NOT : Şimdi eklediğiniz iki belgeye baktım. Aynen dediğim gibi bazı paragraflarda sağ girinti "121 px", Bazılarında 17 px bazılarında 15 px.
Bunların hepsini minimum yapmalısınız. Mesela tüm sağ ve sol girinti 1 px olsun.

 

[necati]

Ben verdiğiniz uzun ders isimlerini kendi makromda denedim sonuç olumlu. Kendi kodlarımı ekliyorum. Altına da ders birleştirme kodlarını düzenleyip sizinkileri ekliyorum.

Option Explicit
Sub MSWord_Ders_Programi3()
Dim wrdApp As Object
Dim wrdDoc As Object
Dim ws As Worksheet, sablon As String
Dim i As Integer, j As Integer, k As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer
Dim ayniders1 As String, ayniders2 As String

Set ws = ThisWorkbook.Sheets("Sayfa1")
sonsat = ActiveSheet.UsedRange.Rows.Count
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
Set wrdDoc = wrdApp.Documents.Add(sablon)
derssay = wrdDoc.Tables(1).Columns.Count - 1

If derssay < Int((sonsat - 5) / 3) Then
ekle = Int((sonsat - 5) / 3) - derssay
    For i = 1 To ekle
        wrdDoc.Tables(1).Columns.Add
    Next i
wrdDoc.Tables(1).Rows.Alignment = wdAlignRowCenter
MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
End If

For j = 2 To 6
    i = 5
    For k = 2 To Int((sonsat - 5) / 3) + 1
        If ws.Cells(i, j).MergeCells = False Then
            wrdDoc.Tables(1).cell(j, k).Range.Text = _
            ws.Cells(i, j).Text & vbNewLine & _
            ws.Cells(i + 1, j).Text & vbNewLine & _
            ws.Cells(i + 2, j).Text
            i = i + 3
        Else
            wrdDoc.Tables(1).cell(j, k).Range.Text = _
            ws.Cells(i, j).Text
            i = i + 3
        End If
    Next k
Next j

derssay = wrdDoc.Tables(1).Columns.Count
For j = 2 To 6
    For k = derssay To 3 Step -1
        With wrdDoc.Tables(1)
        ayniders1 = Replace(.cell(j, k).Range.Text, Chr(13), "")
        ayniders2 = Replace(.cell(j, k - 1).Range.Text, Chr(13), "")
        If ayniders1 = ayniders2 And Len(Replace(.cell(j, k).Range.Text, Chr(13), "")) > 2 Then
            .cell(j, k).Range.Delete
            .cell(j, k - 1).Merge MergeTo:=.cell(j, k)
        End If
        End With
    Next k
Next j

wrdDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)
        
wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & 3).Text & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing

wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Belge hazırlandı", vbInformation
End Sub

Kendi kodlarınız

Option Explicit
Sub MSWord_Ders_Programi()
    Dim wrdApp As Object ' Changed to Object for late binding
    Dim wrdDoc As Object ' Changed to Object for late binding
    Dim ws As Worksheet, sablon As String
    Dim i As Integer, j As Integer, k As Integer
    Dim sonsat As Integer, derssay As Integer, ekle As Integer
    Dim tbl As Object ' Changed to Object for late binding
    Dim ayniders1 As String, ayniders2 As String

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    sonsat = ws.UsedRange.Rows.Count
    On Error GoTo 0 ' Recommended to turn off error resume after critical code

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

    sablon = ThisWorkbook.Path & "\" & "YENİ.docx"
    Set wrdDoc = wrdApp.Documents.Add(sablon)
    Set tbl = wrdDoc.Tables(1)
    derssay = tbl.Columns.Count - 1

    ' Gerekirse yeni sütun ekleyin
    If derssay < Int((sonsat - 5) / 3) Then
        ekle = Int((sonsat - 5) / 3) - derssay
        For i = 1 To ekle
            tbl.Columns.Add
        Next i
        MsgBox "Tabloya yeni sütun eklendi, kontrol ediniz.", vbInformation
    End If

    ' Excel'deki verileri Word tablosuna kopyalayın
    For j = 2 To 6
        i = 5
        For k = 2 To Int((sonsat - 5) / 3) + 1
            If ws.Cells(i, j).MergeArea.Cells.Count = 1 Then
                tbl.cell(j, k).Range.Text = _
                ws.Cells(i, j).Text & vbNewLine & _
                ws.Cells(i + 1, j).Text & vbNewLine & _
                ws.Cells(i + 2, j).Text
                i = i + 3
            Else
                tbl.cell(j, k).Range.Text = _
                ws.Cells(i, j).Text
                i = i + 3
            End If
        Next k
    Next j

    ' Tabloyu sabitlemek ve taşmasını engellemek için ayarlar
    With tbl
        .AllowAutoFit = True ' Otomatik boyutlandırmayı etkinleştir
        
        ' Tablonun pencereye sığmasını sağlamak için tablo genişliğini ayarlayın
        .PreferredWidthType = 2 ' Yüzde olarak genişlik
        .PreferredWidth = 100 ' %100 genişlik

        ' Sütun genişliklerini manuel olarak ayarlayın (cm cinsinden)
        Dim colWidth As Single
        colWidth = wrdDoc.PageSetup.PageWidth / .Columns.Count ' Sütun genişliğini pencere genişliğine göre ayarla
        For i = 1 To .Columns.Count
            .Columns(i).Width = colWidth
        Next i

        ' Tablonun sabit bir yerde kalması için metin hizalaması ve boşluk ayarları
        Dim cell As Object ' Changed to Object for late binding
        For Each cell In .Range.Cells
            cell.Range.ParagraphFormat.SpaceAfter = 0 ' Paragraf sonrası boşluk bırakma
            cell.Range.ParagraphFormat.SpaceBefore = 0 ' Paragraf öncesi boşluk bırakma
            cell.Range.ParagraphFormat.Alignment = 1 ' Metni ortalayın
            cell.VerticalAlignment = 1 ' Dikey hizalama
        Next cell
    End With
    
    ' Tekrar eden hücreleri birleştirin
derssay = wrdDoc.Tables(1).Columns.Count
For j = 2 To 6
    For k = derssay To 3 Step -1
        With wrdDoc.Tables(1)
        ayniders1 = Replace(.cell(j, k).Range.Text, Chr(13), "")
        ayniders2 = Replace(.cell(j, k - 1).Range.Text, Chr(13), "")
        If ayniders1 = ayniders2 And Len(Replace(.cell(j, k).Range.Text, Chr(13), "")) > 2 Then
            .cell(j, k).Range.Delete
            .cell(j, k - 1).Merge MergeTo:=.cell(j, k)
        End If
        End With
    Next k
Next j
    ' Belgeyi kaydedin ve kapatın
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & ws.Range("A3").Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belge hazırlandı", vbInformation
End Sub