Answered by:
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
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 ?
- Edited by webmaster57100 Wednesday, December 13, 2017 10:29 AM
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