Excel İle word dosyası açıp, bu dosyayı farklı kaydetme.

[baran7235]

Merhabalar.

excel ile belirli bir konumdaki 2 word dosyasını açıp birinci dosyadan 2. dosyaya bir metin kopyalıyorum. sonrasında 2. dosyayı farklı bir konuma farklı bir isim ile "farklı kaydetmek" istiyorum fakat bu son aşamada sıkıntı yaşıyorum. desteklerinizi bekliyorum.

Sub OpenDocFromExcel()

    Dim wordapp As Object
    Dim wordapp2 As Object
    Dim strFile As String
    
    dosyayolu = "C:\Users\a\Desktop\b\11.docx"
    dosyayolu2 = "C:\Users\a\Desktop\b\22.docx"
    Set wordapp = CreateObject("word.Application")
    Set wordapp2 = CreateObject("word.Application")
    wordapp.Documents.Open dosyayolu
    wordapp2.Documents.Open dosyayolu2
    wordapp.Visible = True
    wordapp2.Visible = True
    wordapp.Selection.WholeStory
    wordapp.Selection.Copy
    wordapp2.Selection.Paste

    
      Application.Wait Now + TimeValue("00:00:02")
    
 wordapp2.SaveAs2 dosyayolu & "x", 16

  
wordapp.Quit
wordapp2.Quit
 
End Sub

 

[Delioyuncu12x]

Merhabalar.

excel ile belirli bir konumdaki 2 word dosyasını açıp birinci dosyadan 2. dosyaya bir metin kopyalıyorum. sonrasında 2. dosyayı farklı bir konuma farklı bir isim ile "farklı kaydetmek" istiyorum fakat bu son aşamada sıkıntı yaşıyorum. desteklerinizi bekliyorum.

Sub OpenDocFromExcel()

    Dim wordapp As Object
    Dim wordapp2 As Object
    Dim strFile As String
   
    dosyayolu = "C:\Users\a\Desktop\b\11.docx"
    dosyayolu2 = "C:\Users\a\Desktop\b\22.docx"
    Set wordapp = CreateObject("word.Application")
    Set wordapp2 = CreateObject("word.Application")
    wordapp.Documents.Open dosyayolu
    wordapp2.Documents.Open dosyayolu2
    wordapp.Visible = True
    wordapp2.Visible = True
    wordapp.Selection.WholeStory
    wordapp.Selection.Copy
    wordapp2.Selection.Paste

   
      Application.Wait Now + TimeValue("00:00:02")
   
wordapp2.SaveAs2 dosyayolu & "x", 16

 
wordapp.Quit
wordapp2.Quit

End Sub

Bende de aynı sorun var çözemedim hala

 

[baran7235]

ben halledebildim hocam. kodunuzu buraya yazabilirseniz yardımcı olmaya çalışayım size.

 

[halit3]

Bunu denermisiniz.

Sub OpenDocFromExcel()


Dim wordapp1 As Word.Application
Dim wordapp2 As Word.Application
Dim myDoc1  As Word.Document
Dim myDoc2  As Word.Document


dosyayolu1 = ThisWorkbook.Path & "\11.doc"
dosyayolu2 = ThisWorkbook.Path & "\22.doc"
Set wordapp1 = CreateObject("word.Application")
Set wordapp2 = CreateObject("word.Application")

Set myDoc1 = wordapp1.Documents.Open(dosyayolu1)
Set myDoc2 = wordapp2.Documents.Open(dosyayolu2)

wordapp1.Visible = True
wordapp2.Visible = True
wordapp1.Selection.WholeStory
wordapp1.Selection.Copy
wordapp2.Selection.Paste
myDoc2.SaveAs ThisWorkbook.Path & "\x.doc"
myDoc2.Close

wordapp1.Quit
wordapp2.Quit
MsgBox "işlem tamam"
End Sub

 

[halit3]

Sub OpenDocFromExcel()


Dim wordapp1 As Word.Application
Dim wordapp2 As Word.Application
Dim myDoc1  As Word.Document
Dim myDoc2  As Word.Document


dosyayolu1 = "C:\Users\a\Desktop\b\11.docx"
dosyayolu2 = "C:\Users\a\Desktop\b\22.docx"
Set wordapp1 = CreateObject("word.Application")
Set wordapp2 = CreateObject("word.Application")

Set myDoc1 = wordapp1.Documents.Open(dosyayolu1)
Set myDoc2 = wordapp2.Documents.Open(dosyayolu2)

wordapp1.Visible = True
wordapp2.Visible = True
wordapp1.Selection.WholeStory
wordapp1.Selection.Copy
wordapp2.Selection.Paste
myDoc2.SaveAs "C:\Users\a\Desktop\b\x.docx"
myDoc2.Close

wordapp1.Quit
wordapp2.Quit
MsgBox "işlem tamam"
End Sub

 

[baran7235]

Halit Bey, cevaplar için teşekkürler.