Что я могу сделать, чтобы ускорить мой код?

Question

У меня есть скрипт, который я использую, который идет вниз по столбцу на втором листе и извлекает только тех менеджеров (данные их сотрудников), которые я указал.

Формирование каждого файла из обоих массивов занимает примерно 0,8-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