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

Question

Hi,

I create a macro in Excel for exporting data in Word:

Sub export_workbook_to_word()
    Dim sheetName As String
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newobj = obj.Documents.Add
    
    For Each ws In ActiveWorkbook.Sheets
        sheetName = ws.Name
        
        'Retrieve name of the Worksheet
        newobj.ActiveWindow.Selection.TypeText sheetName
        newobj.ActiveWindow.Selection.Style = ActiveDocument.Styles(-2)
        newobj.ActiveWindow.Selection.TypeParagraph

        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 & "\" & Split(ActiveWorkbook.Name, ".")(0)

End Sub

It's working correctly. I would like to create a prompt for selecting the origin folder (with Excel files) and the destination folder (Word files created with the script).

I try to put:

    
    Dim strFolderExcel As String
    Dim strFolderWord As String

    Dim objDocExcel As Excel.Document

    
    strFolderExcel = InputBox("Enter path to Excel documents:")
    strFolderWord = InputBox("Enter path to Word documents:")

    strFileSpec = "*.xls"
    strFileName = Dir(strFolderExcel & strFileSpec)
    Do While strFileName <> vbNullString

But after I'm blocking

Could you please help me to do that?

Regards

Answer 1

Try the code below, untested!

Andreas.

Sub excel_to_word()
  Dim xlWb As Excel.Workbook
  Dim xlWs As Excel.Worksheet
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Path As String
  Dim i As Long

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Pick 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(msoFileDialogOpen)
    .AllowMultiSelect = True
    .Title = "Pick Excel documents"
    .FilterIndex = 2
    If Not .Show Then Exit Sub

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

    For i = 1 To .SelectedItems.Count
      Set xlWb = 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
    Next
  End With
  wdApp.Quit
End Sub

Answer 2

Try the code below, untested!

Andreas.

Sub excel_to_word()
  Dim xlWb As Excel.Workbook
  Dim xlWs As Excel.Worksheet
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Path As String
  Dim i As Long

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Pick 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(msoFileDialogOpen)
    .AllowMultiSelect = True
    .Title = "Pick Excel documents"
    .FilterIndex = 2
    If Not .Show Then Exit Sub

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

    For i = 1 To .SelectedItems.Count
      Set xlWb = 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
    Next
  End With
  wdApp.Quit
End Sub

Hi,

Thanks for the reply.

There is a problem with the line :

      Set xlWb = Workbooks.Open(.SelectedItems(i), False, True)

Could you please help me to solve that?

Regards

Answer 3

There is a problem with the line :

      Set xlWb = Workbooks.Open(.SelectedItems(i), False, True)

I've tested the code with simple sample files, it works. What is your "problem"?

Andreas.

Answer 4

There is a problem with the line :

      Set xlWb = Workbooks.Open(.SelectedItems(i), False, True)

I've tested the code with simple sample files, it works. What is your "problem"?

Andreas.

Sorry I done an error by copy paste. It's working very well. Thank you very much

At the end, all files are opened in Excel and Word. I added that for hide when file is opened:

ActiveWindow.Visible = False

I don't know if it's the good way because when I close excel, the system asks me if I want to save the modifications on each excel file.

A last question:

The script is now executed from Excel. But I created another script in Word for comparing several word documents. Could you tell me please if I can use this excel script directly in word (or do the same in word in order to use only word for launching all scripts ?

Answer 5

The code below can also be executed within PowerPoint.

Andreas.

Sub excel_to_word()
  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 = "Pick 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 = "Pick Excel 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

Answer 6

The code below can also be executed within PowerPoint.

Andreas.

Sub excel_to_word()
  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 = "Pick 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 = "Pick Excel 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

Thank you very much you are my savior :-)