从Excel导出到Word需要很长时间在MAC上

Question

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

Answer 1

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

在Excel中有许多提高执行速度的选项(更多细节请参见这篇文章 )，但是在复制粘贴时最有用的方法当然是设置：

Application.ScreenUpdating = False

但是，由于在Word中粘贴，您必须对Word Application执行相同的操作，以获得最大的速度改进：

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不一定是相互排斥的。