Sub ЯкРомантично_InExSu()
  Sheets("Лист1").Copy After:=Sheets(1)
  Cells.MergeCells = False
  Columns("F:F").Cut
  Columns("D:D").Select
  ActiveSheet.Paste
  Rows("6:6").Delete Shift:=xlUp
  arr = Range("a6").CurrentRegion.Value
  For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
      istr = istr & " " & arr(i, j)
    Next j
    istr = istr & "; "
  Next i
  Range("A1") = istr
  Call Peredacha_Dannyh_iz_Excel_v_Word
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  Application.DisplayAlerts = True
End Sub

Sub Peredacha_Dannyh_iz_Excel_v_Word() 'http://macros-vba.ru/makrosy/excel/159-kak-otkryt-word-iz-excel-makrosom-zapusk-word-iz-excel
  Dim objWrdApp As Object
  Dim objWrdDoc As Object
  On Error Resume Next
  Set objWrdApp = GetObject(, "Word.Application")
  If objWrdApp Is Nothing Then
    Set objWrdApp = CreateObject("Word.Application")
    Set objWrdDoc = objWrdApp.Documents.Open("C:\Doc1.doc")
    objWrdApp.Visible = False
  End If
  Set objWrdDoc = objWrdApp.Documents.Open("C:\Doc1.doc") 'должен быть создан ранее
  Range("A1").Copy
  objWrdDoc.Range(0).Paste
  objWrdDoc.Close True
  'True - с сохранением, False - без сохранения
  objWrdApp.Quit
  Set objWrdDoc = Nothing
  Set objWrdApp = Nothing
End Sub