有什么我可以做的加速我的代码吗？

Question

我有一个脚本，该脚本会在第二个工作表的下一列中列出，并且仅拉出我指定的经理（他们的雇员数据）。

从两个阵列形成每个文件大约需要0.8-0.9秒（一个用于存储，第二个用于更快地打印到新的wb）

您是否需要进行任何修订以大幅度提高速度？我知道大部分时间都在保存/密码保护上。

脚本：

Option Explicit

Sub HR_Assessment()
Dim j As Long, k As Long, x As Long ' counters
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 75, 1 To 1)

Dim strManager As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook

Dim mgrRow As Long ' counter
Dim colManager As Long ' the column manager appears in
colManager = 1

BASEPATH = "M:\Raw Reports\HR\"

Call Ludicrous(True) - this is just a separate module that turns off calculations/screen updating/etc....

For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
    If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 1) <> "" Then
        strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 1)

        With ThisWorkbook.Worksheets("Sheet1")
            ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
            x = 1
            For k = 1 To UBound(varArray, 1)
                varArray(k, x) = .Cells(1, k)
            Next
            For j = 1 To .UsedRange.Rows.Count + 1
                If strManager = .Cells(j, colManager) Then
                    x = x + 1
                    ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
                    For k = 1 To UBound(varArray, 1)

                            varArray(k, x) = .Cells(j, k)

                        strManager = .Cells(j, colManager)
                    Next
                End If
            Next
        End With

        strNewPath = BASEPATH & "11.01.18" & "\"
        If Len(Dir(strNewPath, vbDirectory)) = 0 Then
            MkDir strNewPath
        End If
        ' Path is now "constant path" 


        strFileName = strManager & " - " & "HR_Assessment" & ".xlsx"

        ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))

        Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
        With Wb
            With .Worksheets("Sheet1")
                For j = 1 To UBound(varArray, 2)
                    For k = 1 To UBound(varArray, 1)
                        varArray2(j, k) = varArray(k, j)
                    Next
                Next

                .Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
                .Range("A:B").Columns.AutoFit

            End With

            .SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
            .Saved = True
            .Close

        End With
        Set Wb = Nothing
    End If
Next

Call Ludicrous(False)

End Sub