Word 中的 Vba 宏，用于通过提示从 Word 中的 Excel 导出文件

coeurdange57

我从 VBA 开始，我在 Excel 中创建了一个宏，用于在 Word 中导出数据：

Sub ExportToWord()
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newobj = obj.Documents.Add

    For Each ws In ActiveWorkbook.Sheets
        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 & "\OLD\" & Split(ActiveWorkbook.Name, ".")(0)
End Sub

我想直接从 Word（不打开 Excel）执行相同的操作，并提示选择原始文件夹（带有 Excel 文件）和目标文件夹（使用脚本创建的 Word 文件）。

你能帮我做到这一点吗？

问候

coeurdange57

我创建了响应需求的脚本：

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系 [email protected] 删除。