Convertir des fichiers Excel d'un dossier en fichiers Word
a
Bonjour,
J'ai crée une macro vba Excel qui permet de convertir un rapport excel en 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
Ce script fonctionne très bien.
Je voudrais améliorer ce script pour exporter tous les fichiers Excel d'un dossier sélectionné en fichier Word avec une invite pour demander les dossiers des fichiers Excel et le dossier de destination où se trouveront les fichiers Word.
Pourriez-vous m'aider à améliorer ce script En me disant comme mettre en place les invites de commande?
Merci d'avance pour votre aide
a
J'ai trouvé la solution:
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