none
Vba Macro in Excel for exporting multiples files in Word with prompt RRS feed

  • 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


    Tuesday, December 12, 2017 8:19 AM

Answers

  • 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
    

    • Marked as answer by webmaster57100 Wednesday, December 13, 2017 12:44 PM
    Wednesday, December 13, 2017 11:18 AM

All replies

  • 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

    Tuesday, December 12, 2017 3:04 PM
  • 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




    Wednesday, December 13, 2017 7:40 AM
  • 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.

    Wednesday, December 13, 2017 8:10 AM
  • 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 ?





    Wednesday, December 13, 2017 10:14 AM
  • 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
    

    • Marked as answer by webmaster57100 Wednesday, December 13, 2017 12:44 PM
    Wednesday, December 13, 2017 11:18 AM
  • 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 :-)
    Wednesday, December 13, 2017 12:46 PM