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

[coeurdange57]

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).

Could you please help me to do that?
Regards

[Kenneth Hobs]

Welcome to the forum!

Sub test_GetFolder()  
  MsgBox GetFolder("Get My Folder", ThisWorkbook.path)
End Sub

Function GetFolder(Optional sTitle As String = "Select Folder", _
  Optional sInitialFilename As String)
  Dim myFolder As String
  With Application.FileDialog(msoFileDialogFolderPicker)
    If sInitialFilename = "" Then sInitialFilename = ThisWorkbook.path


    .initialFilename = sInitialFilename
    .Title = "Greetings"
    If .show = -1 Then
      GetFolder = .SelectedItems(1)
      If Right(GetFolder, 1) <> "\" Then
            GetFolder = GetFolder & "\"
      End If
      Else: GetFolder = ""
    End If
  End With
End Function

[snb]

Code rewritten:

Sub M_snb() 
  with createobject("Word.document")
    For Each it In ActiveWorkbook.Sheets 
      .content.insterafter it.name & cvbcr & vbcr
      it.usedange.copy
      .paragraphs.last.range.paste
      .insertbreak
    Next 
    .SaveAs ActiveWorkbook.Path & "\" & Split(ActiveWorkbook.Name, ".")(0) 
   end with
End Sub

[snb]

Crossposted/doubly posted: http://www.vbaexpress.com/forum/show...for-Comparison