Excel tablosunu Word tablosuna aktarmak

hadromer · 31 Ağustos 2024

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.

Kod:

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

Kod:

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

Necati Bey emeğinize sağlık yordum sizi. Ancak sizin kodları denediğimde wrdDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow) kısmında not defined hatası alıyorum. kendi kodlarımı denediğimde derslerdeki birleştirme kodu çalışmıyor. acaba neyi yanlış yapıyorum ?

hadromer · 31 Ağustos 2024

Tamam şimdi çalıştı. Harika olmuş çok teşekkür ederim tekrardan. Object library silip tekrar aktif ettim düzeldi. Sorunum tamamen giderildi. Çok teşekkürler

necati · 31 Ağustos 2024

hadromer' Alıntı:
Tamam şimdi çalıştı. Harika olmuş çok teşekkür ederim tekrardan. Object library silip tekrar aktif ettim düzeldi. Sorunum tamamen giderildi. Çok teşekkürler

Rica ederim, kolay gelsin. O hata mesajının sebebini 15 nolu mesajda belirtmiştim. Bazan bilgisayarda sebepsiz takılmalar olabiliyor. Klasik kapat/aç mantığının işe yaradığını bir kez daha görmüş olduk.

hadromer · 2 Eylül 2024

necati' Alıntı:
Rica ederim, kolay gelsin. O hata mesajının sebebini 15 nolu mesajda belirtmiştim. Bazan bilgisayarda sebepsiz takılmalar olabiliyor. Klasik kapat/aç mantığının işe yaradığını bir kez daha görmüş olduk.

biraz önce veri güncellemesi yaptılar ve malesef exceldeki satır sayılarımız değişkenlik gösteriyor....

konuyu açıklayan bir mesaj attım size. Kurallara aykırı olmasın diye buradan da yazmak istedim.

ek olarak aynı gün ve saatte 4-5 ders olabiliyor. bu yüzden 5 ders için (kaç ders varsa) yine tekrarlayanları teke düşürüp hücre birleştirme işlemi yapacağız ama birleştirilen hücreyi ders sayısına göre satıra bölüp dersleri oralara yazacağız. 5 ders var ise birleşen hücrede 5 satır olacak... bu güncelleme için bir rica da daha bulunsam. Biliyorum çok yordum sizi ama.. hakkınızı helal edin.

necati · 4 Eylül 2024

Verilerinizin formatında sayfadan sayfaya bazı küçük değişiklikler olmakla beraber mümkün olduğunca esnek bir kod hazırlamaya çalıştım.
Bu yüzden çıktılarda bazı tutarsızlıklar olması muhtemeldir.
Çokul_Satır_Full.xlsx adlı dosya formatına göre hazırlanan makroyu ekliyorum.
Word belgeleri, excel sayfa ismi ile kaydediliyor.
Referanslar Microsoft Word xx.0 Object Library.

Kod:

Option Explicit
Sub MSWord_Ders_Programi4()
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, x As Integer, y As Integer, z As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer
Dim ayniders1 As String, ayniders2 As String, myString As String, my_text As String

Application.StatusBar = ". . . . . . .LÜTFEN BEKLEYİNİZ . . . . . . . ."

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
sablon = ThisWorkbook.Path & "\" & "YENİ.docx"

For y = 1 To Sheets.Count

Set ws = ThisWorkbook.Sheets(y)
sonsat = ws.UsedRange.Rows.Count
Set wrdDoc = wrdApp.Documents.Add(sablon)

With wrdDoc.Tables(1)

derssay = .Columns.Count - 1

i = 1
ReDim myarr(1 To i)
myarr(i) = Cells(5, 1).Row
For x = 5 To sonsat - 1
    ReDim Preserve myarr(1 To i)
    If ws.Cells(x, 1).Borders(xlEdgeBottom).Weight = xlThick Then
    myarr(i) = ws.Cells(x, 1).Row
        i = i + 1
    Else
        Do Until ws.Cells(x, 1).Borders(xlEdgeBottom).LineStyle = 1
         x = x + 1
         If x >= sonsat Then Exit For
        Loop
        i = i + 1
    ReDim Preserve myarr(1 To i)
    myarr(i) = ws.Cells(x, 1).Row
    End If
Next x

ekle = (UBound(myarr)) - derssay

For i = 1 To ekle
    .Columns.Add
Next i

For j = 2 To 6
    i = myarr(1): z = 1
    For k = 2 To UBound(myarr)
        If ws.Cells(i, j).MergeCells = False Then
            Do
                myString = myString & ws.Cells(i, j).Text & vbNewLine
                i = i + 1
            Loop Until i = myarr(z + 1) + 1
            For x = Len(myString) To 1 Step -1
                If Mid(myString, x, 1) Like "[A-Za-z0-9]" Then
                    myString = Left(myString, x)
                    Exit For
                End If
            Next
            .cell(j, k).Range.Text = myString
            myString = ""
        Else
            myString = ws.Cells(i, j).Text
            .cell(j, k).Range.Text = myString
            i = i + ws.Cells(i, j).MergeArea.Rows.Count
        End If
        z = z + 1: myString = ""
    Next k
Next j

For i = .Columns.Count To 2 Step -1
    my_text = .cell(2, i).Range.Text & .cell(3, i).Range.Text & .cell(4, i).Range.Text & .cell(5, i).Range.Text & .cell(6, i).Range.Text
    my_text = Replace(my_text, " ", vbNullString)
    my_text = Replace(my_text, vbCrLf, vbNullString)
    my_text = Replace(my_text, Chr$(13), vbNullString)
    my_text = Replace(my_text, Chr$(7), vbNullString)
    If Len(my_text) = 0 Then
        .Columns(i).Delete
    End If
    my_text = ""
Next i

derssay = .Columns.Count

For j = 2 To 6
    For k = derssay To 3 Step -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
    Next k
Next j

With wrdApp.Selection
    .HomeKey Unit:=wdStory
    .Find.Text = "^p^p"
    .Find.Wrap = wdFindStop
    While .Find.Execute
        .MoveRight Unit:=wdCharacter, Count:=1
        .MoveLeft Unit:=wdCharacter, Count:=1
        .InlineShapes.AddHorizontalLineStandard
        .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        .InlineShapes(1).Fill.Visible = msoTrue
        .InlineShapes(1).Fill.Solid
        .InlineShapes(1).Fill.ForeColor.RGB = RGB(255, 0, 0)
        .InlineShapes(1).Height = 1.5
        .InlineShapes(1).HorizontalLineFormat.NoShade = True
        .MoveRight Unit:=wdCharacter, Count:=1
    Wend
End With

.AutoFitBehavior (wdAutoFitWindow)
End With

wrdDoc.SaveAs ThisWorkbook.Path & "\" & ws.Name & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing
Next y
wrdApp.Quit
Set wrdApp = Nothing
Application.StatusBar = False
MsgBox "Belgeler hazırlandı", vbInformation
End Sub

hadromer · 4 Eylül 2024

necati' Alıntı:

Verilerinizin formatında sayfadan sayfaya bazı küçük değişiklikler olmakla beraber mümkün olduğunca esnek bir kod hazırlamaya çalıştım.
Bu yüzden çıktılarda bazı tutarsızlıklar olması muhtemeldir.
Çokul_Satır_Full.xlsx adlı dosya formatına göre hazırlanan makroyu ekliyorum.
Word belgeleri, excel sayfa ismi ile kaydediliyor.
Referanslar Microsoft Word xx.0 Object Library.

Kod:

Option Explicit
Sub MSWord_Ders_Programi4()
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, x As Integer, y As Integer, z As Integer
Dim sonsat As Integer, derssay As Integer, ekle As Integer
Dim ayniders1 As String, ayniders2 As String, myString As String, my_text As String

Application.StatusBar = ". . . . . . .LÜTFEN BEKLEYİNİZ . . . . . . . ."

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
sablon = ThisWorkbook.Path & "\" & "YENİ.docx"

For y = 1 To Sheets.Count

Set ws = ThisWorkbook.Sheets(y)
sonsat = ws.UsedRange.Rows.Count
Set wrdDoc = wrdApp.Documents.Add(sablon)

With wrdDoc.Tables(1)

derssay = .Columns.Count - 1

i = 1
ReDim myarr(1 To i)
myarr(i) = Cells(5, 1).Row
For x = 5 To sonsat - 1
    ReDim Preserve myarr(1 To i)
    If ws.Cells(x, 1).Borders(xlEdgeBottom).Weight = xlThick Then
    myarr(i) = ws.Cells(x, 1).Row
        i = i + 1
    Else
        Do Until ws.Cells(x, 1).Borders(xlEdgeBottom).LineStyle = 1
         x = x + 1
         If x >= sonsat Then Exit For
        Loop
        i = i + 1
    ReDim Preserve myarr(1 To i)
    myarr(i) = ws.Cells(x, 1).Row
    End If
Next x

ekle = (UBound(myarr)) - derssay

For i = 1 To ekle
    .Columns.Add
Next i

For j = 2 To 6
    i = myarr(1): z = 1
    For k = 2 To UBound(myarr)
        If ws.Cells(i, j).MergeCells = False Then
            Do
                myString = myString & ws.Cells(i, j).Text & vbNewLine
                i = i + 1
            Loop Until i = myarr(z + 1) + 1
            For x = Len(myString) To 1 Step -1
                If Mid(myString, x, 1) Like "[A-Za-z0-9]" Then
                    myString = Left(myString, x)
                    Exit For
                End If
            Next
            .cell(j, k).Range.Text = myString
            myString = ""
        Else
            myString = ws.Cells(i, j).Text
            .cell(j, k).Range.Text = myString
            i = i + ws.Cells(i, j).MergeArea.Rows.Count
        End If
        z = z + 1: myString = ""
    Next k
Next j

For i = .Columns.Count To 2 Step -1
    my_text = .cell(2, i).Range.Text & .cell(3, i).Range.Text & .cell(4, i).Range.Text & .cell(5, i).Range.Text & .cell(6, i).Range.Text
    my_text = Replace(my_text, " ", vbNullString)
    my_text = Replace(my_text, vbCrLf, vbNullString)
    my_text = Replace(my_text, Chr$(13), vbNullString)
    my_text = Replace(my_text, Chr$(7), vbNullString)
    If Len(my_text) = 0 Then
        .Columns(i).Delete
    End If
    my_text = ""
Next i

derssay = .Columns.Count

For j = 2 To 6
    For k = derssay To 3 Step -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
    Next k
Next j

With wrdApp.Selection
    .HomeKey Unit:=wdStory
    .Find.Text = "^p^p"
    .Find.Wrap = wdFindStop
    While .Find.Execute
        .MoveRight Unit:=wdCharacter, Count:=1
        .MoveLeft Unit:=wdCharacter, Count:=1
        .InlineShapes.AddHorizontalLineStandard
        .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        .InlineShapes(1).Fill.Visible = msoTrue
        .InlineShapes(1).Fill.Solid
        .InlineShapes(1).Fill.ForeColor.RGB = RGB(255, 0, 0)
        .InlineShapes(1).Height = 1.5
        .InlineShapes(1).HorizontalLineFormat.NoShade = True
        .MoveRight Unit:=wdCharacter, Count:=1
    Wend
End With

.AutoFitBehavior (wdAutoFitWindow)
End With

wrdDoc.SaveAs ThisWorkbook.Path & "\" & ws.Name & ".docx"
wrdDoc.Close False
Set wrdDoc = Nothing
Next y
wrdApp.Quit
Set wrdApp = Nothing
Application.StatusBar = False
MsgBox "Belgeler hazırlandı", vbInformation
End Sub

Necati Bey Merhaba,
Kodu referansla birlikte uyguladım. Çalıştı. Ancak bazı sınıflarda tablo boş. Sadece günler yazıyor. Hata ile ilgili bir görsel ekledim. https://hizliresim.com/h1t1sro

necati · 4 Eylül 2024

Bendeki dosyanızda ders verisi olmayan sayfalarda bu şekilde oluyor.
Dediğim gibi eğer bazı sayfalar tam istediğiniz gibi oluyor, bazıları tutarsız oluyorsa bu verilerinizde farklı formatlar olmasından kaynaklanıyordur.

hadromer · 4 Eylül 2024

necati' Alıntı:
Bendeki dosyanızda ders verisi olmayan sayfalarda bu şekilde oluyor.
Dediğim gibi eğer bazı sayfalar tam istediğiniz gibi oluyor, bazıları tutarsız oluyorsa bu verilerinizde farklı formatlar olmasından kaynaklanıyordur.

size gönderdiğim dosyada uyguladım. kod bitince wordde tabloları siler gibi bir işlem yapıyor acaba o esnada mı siliniyor son 3 sınıfa ait program bilemedim. Ama sizi daha fazla yormak istemiyorum, yeterince zahmet verdim MAhçup hissediyorum kendimi. Emeklerinize sağlık

hadromer · 4 Eylül 2024

Necati Bey Çok özür dilerim son iki sayfa boşmuş. Problem yok gayet iyi çalışıyor. Teşekkür ederim

necati · 4 Eylül 2024

İlk başta exceldeki saat sütununa göre boş tablo sütunları oluşturuluyor. Sonra ders verisi olmayan sütunları silmek için makro sonuna silme işlemi konuldu. Böylece tablo gereksiz genişlememiş oluyor. Boş sayfalarda da aynı mantıktan dolayı ders yok gibi algılayıp boş sütunlar siliniyor. Kolay gelsin.