Çözüldü Excelden Word dosyası doldurup kaydetme hak.

[mkarakas_58]

Merhaba üstadlar,

Excelde bulunan tablodaki verileri, Word halindeki denetim raporunda belirlediğim yer imlerine ekleyerek word dosyasını farklı kaydetmek istiyorum.

Aşağıdaki kodda hata alıyorum. Ayrıca excel çok kasıyor.


---------------------

Private Sub CommandButton1_Click()

Dim doc As Word.Document
Set wordapp = CreateObject("word.application")
sablon = "C:\Users\mehmet.karakas\Desktop\2025 Denetim\MEK.docx"

For i = 2 To 7
Set doc = wordapp.Documents.Open(sablon)
doc.Bookmarks("protokoltarih").Range.InsertAfter Cells(i, 10)
doc.Bookmarks("protokolno").Range.InsertAfter Cells(i, 9)
doc.Bookmarks("meslek").Range.InsertAfter Cells(i, 3)
doc.Bookmarks("kursadı").Range.InsertAfter Cells(i, 4)
doc.Bookmarks("firma").Range.InsertAfter Cells(i, 5)
doc.Bookmarks("bitis").Range.InsertAfter Cells(i, 12)
doc.Bookmarks("baslama").Range.InsertAfter Cells(i, 11)
doc.SaveAs2 "C:\Users\mehmet.karakas\Desktop\2025 Denetim\" & Cells(i, 3).Text

wordapp.Documents.Close
wordapp.Quit
Next i

End Sub
-----------------------



yardım ederseniz sevinirim.

 

[Muzaffer Ali]

Merhaba.
Bu kodu kullanın. Yine olmazsa word dosyanızı da paylaşın.

Private Sub CommandButton1_Click()
    Dim doc As Word.Document
    Set wordapp = CreateObject("word.application")
    sablon = "C:\Users\mehmet.karakas\Desktop\2025 Denetim\MEK.docx"
    Set doc = wordapp.Documents.Open(sablon)
    
    For i = 2 To 7
        doc.Bookmarks("protokoltarih").Range.InsertAfter Cells(i, 10)
        doc.Bookmarks("protokolno").Range.InsertAfter Cells(i, 9)
        doc.Bookmarks("meslek").Range.InsertAfter Cells(i, 3)
        doc.Bookmarks("kursadı").Range.InsertAfter Cells(i, 4)
        doc.Bookmarks("firma").Range.InsertAfter Cells(i, 5)
        doc.Bookmarks("bitis").Range.InsertAfter Cells(i, 12)
        doc.Bookmarks("baslama").Range.InsertAfter Cells(i, 11)
        doc.SaveAs2 "C:\Users\mehmet.karakas\Desktop\2025 Denetim\" & Cells(i, 3).Text
    Next i
    
    wordapp.Documents.Close
    wordapp.Quit
End Sub

 

[mkarakas_58]

Hata verdi hocam,

Word ve excel dosyası ekte

Download

A file is available for download and streaming via UploadNow by following this link

uploadnow.io

 

[Muzaffer Ali]

Excel dosyasındaki kodu silip yerine aşağıdakini kopyalayın.

Private Sub CommandButton1_Click()
    Dim Doc As Word.Document
    Dim WordApp As Word.Application
    Dim Sablon As String
    Dim i As Integer
   
    Sablon = "C:\Users\mehmet.karakas\Desktop\2025 Denetim\"

    Set WordApp = New Word.Application
    Set Doc = WordApp.Documents.Open(Sablon & "MEK.docx")
   
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Doc.Bookmarks("protokoltarih").Range.InsertAfter Cells(i, 10)
        Doc.Bookmarks("protokolno").Range.InsertAfter Cells(i, 9)
        Doc.Bookmarks("meslek").Range.InsertAfter Cells(i, 3)
        Doc.Bookmarks("kursadı").Range.InsertAfter Cells(i, 4)
        Doc.Bookmarks("firma").Range.InsertAfter Cells(i, 5)
        Doc.Bookmarks("bitis").Range.InsertAfter Cells(i, 12)
        Doc.Bookmarks("baslama").Range.InsertAfter Cells(i, 11)
        Doc.SaveAs2 Sablon & Cells(i, 3).Text
    Next
   
    Doc.Close
    WordApp.Quit
    MsgBox "Tamamlandı.", vbExclamation
End Sub

 

[mkarakas_58]

Exceldeki 1. satır kaydediyor, i=1 tamam, i=2de i=1dekilerin yanına ekliyor. Mesela i=3 deki 3. word dosyasında exceldeki ilk 3 satırdaki verilerin hepsi gözüküyor.

 

[necati]

Exceldeki 1. satır kaydediyor, i=1 tamam, i=2de i=1dekilerin yanına ekliyor. Mesela i=3 deki 3. word dosyasında exceldeki ilk 3 satırdaki verilerin hepsi gözüküyor.

Merhaba, Muzaffer Ali beyin kodundan uyarlanmıştır.

Private Sub CommandButton1_Click()
    Dim Doc As Word.Document
    Dim WordApp As Word.Application
    Dim Sablon As String
    Dim i As Integer
  
    Sablon = "C:\Users\mehmet.karakas\Desktop\2025 Denetim\"

    Set WordApp = New Word.Application
  
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
    Set Doc = WordApp.Documents.Open(Sablon & "MEK.docx")
        Doc.Bookmarks("protokoltarih").Range.InsertAfter Cells(i, 10)
        Doc.Bookmarks("protokolno").Range.InsertAfter Cells(i, 9)
        Doc.Bookmarks("meslek").Range.InsertAfter Cells(i, 3)
        Doc.Bookmarks("kursadı").Range.InsertAfter Cells(i, 4)
        Doc.Bookmarks("firma").Range.InsertAfter Cells(i, 5)
        Doc.Bookmarks("bitis").Range.InsertAfter Cells(i, 12)
        Doc.Bookmarks("baslama").Range.InsertAfter Cells(i, 11)
        Doc.SaveAs2 Sablon & Cells(i, 3).Text
    Doc.Close
    Next
  
    WordApp.Quit
    MsgBox "Tamamlandı.", vbExclamation
End Sub

 

[mkarakas_58]

teşekkür ederim sorun çüzüldü.