VBA copy from excel to word

[petars87]

Hi people,

I have this code which I want to improve

  Sub CopyToWord()
     Dim objWord As Object
     Dim objDoc As Object
     Set objWord = CreateObject("Word.Application")
     Set objDoc = objWord.Documents.Add(Template:= _
         "[URL="file://\\xxx\vb\PetarTest\template.docx"]\\xxx\vb\PetarTest\template.docx[/URL]")
         
     Set Ar = Worksheets("Sheet1").Range("A1:F" & Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row)
    
     Ar.Copy
     
     objDoc.Range.Paste
     
     objWord.Visible = True
     Set objDoc = Nothing
     Set objWord = Nothing
 End Sub

i changed range an now i have :

Sub CopyToWord()
     Dim objWord As Object
     Dim objDoc As Object
     Dim i As Long
     Dim LR As Long
     
     Set objWord = CreateObject("Word.Application")
     Set objDoc = objWord.Documents.Add(Template:= _
         "[URL="file://\\xxx\vb\PetarTest\template.docx"]\\xxx\vb\PetarTest\template.docx[/URL]")
     
     
     
     LR = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
     
    For i = 0 To LR
     
     Set Ar = Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells((i * 36) + 1, 1), Worksheets("Sheet1").Cells((i * 36) + 36, 6))
     Ar.Copy
     
    '----Here i need your help----
    
    Next i
    
    Set objDoc = Nothing
    Set objWord = Nothing
   
    
 End Sub

How to copy all this ranges in separated word documents, save them and close at the end?

Thank you.

 

[Macropod]

Where do the names for these documents come from? You can't save one without giving it a name. Also, what folder are they to be saved to?

 

[petars87]

I know that i should specify name and location but exactly that syntax is my question
i don't know how to specify that, so in that part of code where name and location is specified i need ur help

i was trying with these but doesn't work(don't lough):

Sub CopyToWord()
     Dim objWord As Object
     Dim objDoc As Object
     Dim i As Long
     Dim LR As Long
     
     Set objWord = CreateObject("Word.Application")
     Set objDoc = objWord.Documents.Add(Template:= _
         "[URL="file://xxx/vb/PetarTest/template.docx"]\\xxx\vb\PetarTest\template.docx[/URL]")
     
     
     
     LR = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
     
    For i = 0 To LR
     
     Set Ar = Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells((i * 36) + 1, 1), Worksheets("Sheet1").Cells((i * 36) + 36, 6))
     Ar.Copy
     
   
   'ChDir "C:\Users\xxx\Desktop\Fie\BUD"
    'wbNam = "BUD_"
    'dt = Format(CStr(Now), "yyyy_mm_dd_hh_mm")
    'objDoc.Range.Paste
  ' objWord.SaveAs Filename:= _
   '       wbNam & dt & Environ("UserName") 
  'objDoc.Close
    Next i
    
    Set objDoc = Nothing
    Set objWord = Nothing
   
    
 End Sub

Thak you.

 

[Macropod]

Try something along the lines of:

Sub CopyToWord()
Dim objWord As Object, objDoc As Object, i As Long, strPath As String, strName As String
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
strPath = "C:\Users\" & Environ("UserName") & "\Desktop\Fie\BUD\"
strName = "BUD_" & Format(Now, "yyyy_mm_dd_hh_mm_")
With Sheets("Sheet1")
  For i = 0 To .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range(.Cells((i * 36) + 1, 1), .Cells((i * 36) + 36, 6)).Copy
    Set objDoc = objWord.Documents.Add(Template:="\\" & Environ("UserName") & "\vb\PetarTest\template.docx")
    With objDoc
      .Range.Paste
      .SaveAs2 strPath & strName & "(" & Format(i, "00") & ").docx", 12 '12=XML document format.
      .Close
    End With
  Next i
End With
objWord.Quit
Set objDoc = Nothing: Set objWord = Nothing
End Sub

Note that I've added the 'i' counter to the filename; simply using the current date & time with only one-minute accuracy would result in files being overwritten.

 

[petars87]

Thank you very very much @Macropod
Nice idea for counter in name! Thanks once again!