1

我有一个脚本，可以将特定范围的单元格从 Excel 导出到 Word。下面你可以看到脚本

Sub Export_to_Word_Mac()
Dim filename As String
Dim FolderName As String
Dim Folderstring As String
Dim FilePathName As String
Dim sh As Worksheet
Dim print_area As Range
Dim appWD As Object
Dim wddoc As Object
Dim rng As Range
Dim paragraphCount As Long

Set sh = ThisWorkbook.Sheets("Sheet1")

sh.Unprotect
sh.Rows("15:16").EntireRow.Hidden = True

  For Each rng In sh.Range("B17:B26")
        If rng.Value Like "wpisz zakres usług tutaj..." Then
            rng.EntireRow.Hidden = True
        Else
            rng.EntireRow.Hidden = False
        End If
    Next rng
    
sh.Protect

    FolderName = "Export"
    
    filename = sh.Range("G4") & "_test_" & Format(Now, "dd-mm-yyyy_hhmm") & ".docx"

    Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
    FilePathName = Folderstring & Application.PathSeparator & filename

On Error Resume Next
   Set appWD = GetObject(, "Word.application")
    If Err = 429 Then
        Set appWD = CreateObject("Word.application")
        Err.Clear
    End If

    Set wddoc = appWD.Documents.Add
    appWD.Visible = True

    With appWD.ActiveDocument.PageSetup
        .TopMargin = appWD.InchesToPoints(0.5)
        .BottomMargin = appWD.InchesToPoints(0.5)
        .LeftMargin = appWD.InchesToPoints(0.5)
        .RightMargin = appWD.InchesToPoints(0.5)
    End With
    
   'copy range to word
    Set print_area = sh.Range("B1:C27")

    print_area.Copy

    'paste range to Word table
    paragraphCount = wddoc.Content.Paragraphs.Count
    wddoc.Paragraphs(paragraphCount).Range.Paste
    Application.CutCopyMode = False

    appWD.ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter
    appWD.ActiveDocument.Cells.VerticalAlignment = wdCellAlignVerticalTop
   'appWD.Activate
    appWD.ActiveDocument.SaveAs (FilePathName)

    MsgBox "Plik zostal zapisany jako: " & vbNewLine & filename & vbNewLine & _
    " w nowo stworzonym " & FolderName & " w folderze: " & vbNewLine & "Library/Group Containers/UBF8T346G9.Office/"
    
    appWD.Quit
    
    Set wddoc = Nothing
    Set appWD = Nothing
    
End Sub

Function CreateFolderinMacOffice2016(NameFolder As String) As String

    Dim OfficeFolder As String
    Dim PathToFolder As String
    Dim TestStr As String

    OfficeFolder = MacScript("return POSIX path of (path to desktop folder) as string")
    OfficeFolder = Replace(OfficeFolder, "/Desktop", "") & _
        "Library/Group Containers/UBF8T346G9.Office/"

    PathToFolder = OfficeFolder & NameFolder

    On Error Resume Next
    TestStr = Dir(PathToFolder & "*", vbDirectory)
    On Error GoTo 0
    If TestStr = vbNullString Then
        MkDir PathToFolder
        'MsgBox "You find the new folder in this location :" & PathToFolder
    End If
    CreateFolderinMacOffice2016 = PathToFolder
End Function

不幸的是，有几个问题：

  1. 导出和保存 Word 文件需要 1,5-2 分钟。你能帮我优化代码吗？
  2. 我需要在我的 Mac 上打开 Word 应用程序来运行脚本。否则我得到运行时错误'9'（脚本超出范围）。问题在于这一行：Set appWD = GetObject(, "Word.application").
  3. 我想出的唯一解决方案是使用.CopyPicture xlScreen并将其粘贴到 Word 文档中。我用 arpund 5 秒创建 Word 文件，但内容不可编辑，并保存为图像。
4

1 回答 1

0

选项 1：继续使用 Copy 但优化 VBA 执行

在 Excel VBA 中有许多提高执行速度的选项（有关详细信息，请参阅本文），但在复制粘贴时最有用的肯定是设置：

Application.ScreenUpdating = False

但是，由于您在 Word 中粘贴，因此您必须为 Word 应用程序执行相同的操作才能获得最大的速度提升：

appWD.ScreenUpdating = False

Application.ScreenUpdating = True注意：确保在代码末尾重置。

选项 2：使用数组传输数据

如果不需要在 Excel 中格式化单元格，则可以将单元格的内容加载到数组中，然后将此数组写入 word 文档，如下所示：

'copy range to word
Dim DataArray() As Variant
DataArray = sh.Range("B1:C27").Value

Dim i As Integer, j As Integer
Dim MyWordRange As Object

Set MyRange = appWD.ActiveDocument.Range(0, 0)
appWD.ActiveDocument.Tables.Add Range:=MyRange, NumRows:=UBound(DataArray, 1), NumColumns:=UBound(DataArray, 2)
 
'paste range to Word table
For i = 1 To UBound(DataArray, 1)
    For j = 1 To UBound(DataArray, 2)
        appWD.ActiveDocument.Tables(1).Cell(i, j).Range.Text = DataArray(i, j)
    Next j
Next i

请注意，选项 1 和 2 不一定是互斥的。

于 2020-08-26T23:11:37.270 回答