Vba Macro in Word for exporting files from Excel in Word with prompt

Question

I'm starting with VBA, I create a macro in Excel for exporting data in Word:

Sub ExportToWord()
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newobj = obj.Documents.Add

    For Each ws In ActiveWorkbook.Sheets
        ws.UsedRange.Copy
        newobj.ActiveWindow.Selection.PasteExcelTable False, False, False
        newobj.ActiveWindow.Selection.InsertBreak Type:=7
    Next
        newobj.ActiveWindow.Selection.TypeBackspace
        newobj.ActiveWindow.Selection.TypeBackspace

    obj.Activate
    newobj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\OLD\" & Split(ActiveWorkbook.Name, ".")(0)
End Sub

I would like to do the same but directly from Word (without opening Excel) with a prompt for selecting the origin folder (with Excel files) and the destination folder (Word files created with the script).

Could you please help me to do that?

Regards

Answer 1

I create the script for responding to the need:

Private Sub ExportExcelToWord_Click()

  Dim xlApp As Object 'Excel.Application
  Dim xlWb As Object 'Excel.Workbook
  Dim xlWs As Object 'Excel.Worksheet
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Path As String
  Dim i As Long

  Set xlApp = CreateObject("Excel.Application")
  xlApp.EnableEvents = False
  xlApp.DisplayAlerts = False

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the destination folder for Word documents"
    If Not .Show Then Exit Sub
    Path = .SelectedItems(1)
    If Right(Path, 1) <> "\" Then Path = Path & "\"
  End With

  With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Title = "Choose the folder with Excel original documents"
    .Filters.Add "Excel files", "*.xls*"
    If Not .Show Then Exit Sub

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    wdApp.DisplayAlerts = 0 'wdAlertsNone

    For i = 1 To .SelectedItems.Count
      Set xlWb = xlApp.Workbooks.Open(.SelectedItems(i), False, True)
      Set wdDoc = wdApp.Documents.Add

      For Each xlWs In xlWb.Worksheets
        wdDoc.ActiveWindow.Selection.TypeText xlWs.Name
        wdDoc.ActiveWindow.Selection.Style = wdDoc.Styles(-2)
        wdDoc.ActiveWindow.Selection.TypeParagraph

        xlWs.UsedRange.Copy
        wdDoc.ActiveWindow.Selection.PasteExcelTable False, False, False
        wdDoc.ActiveWindow.Selection.InsertBreak Type:=7
      Next
      wdDoc.ActiveWindow.Selection.TypeBackspace
      wdDoc.ActiveWindow.Selection.TypeBackspace
      wdDoc.SaveAs Path & Split(xlWb.Name, ".")(0)
      wdDoc.Close False
      xlWb.Close False
    Next
  End With
  On Error Resume Next
  wdApp.Quit
  xlApp.Quit

End Sub