Krdytkyu

I have a script that takes manager names in Sheets("Mgrs") and extracts the employees that fall under each manager in Sheets("Retail Sharepoint File-Merge"). Once it finds the managers employees, it prints the array to a new worksheet and formats it and saves it based on the values I lay out.

Option Explicit



Sub Retail_Cuts()

    Dim j As Long, k As Long, x As Long

    Dim varArray() As Variant

    Dim varArray2() As Variant

    ReDim varArray(1 To 19, 1 To 1)



    Dim strManager As String, strEC As String, strLogin As String

    Dim BASEPATH As String, strNewPath As String, strFileName As String

    Dim Wb As Workbook



    Dim mgrRow As Long

    Dim colManager As Long

    colManager = 3



    Dim colLogin As Long

    colLogin = 4



    Dim colEC As Long

    colEC = 5



    BASEPATH = "M:11-19-2018"



Call Ludicrous(True)



    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("Retail Sharepoint File-Merge")

                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 = 2 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)

                            If k = 1 Then

                                varArray(1, x) = CStr(Format(.Cells(j, k), "000000000"))

                            Else

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

                            End If

                            strEC = .Cells(j, colEC)

                            strManager = .Cells(j, colManager)

                            strLogin = .Cells(j, colLogin)

                        Next

                    End If

                Next

            End With



            strNewPath = BASEPATH & strEC & ""

            If Len(Dir(strNewPath, vbDirectory)) = 0 Then

                MkDir strNewPath

            End If



            strFileName = strLogin & " - " & strManager & " - " & "Shift Differential Validation" & ".xlsx"



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



            Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)

            With Wb

                With .Worksheets("Sheet1")

                    .Columns(1).NumberFormat = "@"

                    .Columns(15).NumberFormat = "0%"

                    .Columns(18).NumberFormat = "0%"



                    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



                        .Columns("N:O").HorizontalAlignment = xlCenter

                        .Columns("Q:Q").HorizontalAlignment = xlLeft

                        .Columns("R:R").HorizontalAlignment = xlCenter

                        .Columns("S:S").HorizontalAlignment = xlLeft



                        Call DataValidation

                        Call Header

                        Call Macro1



                        .Range("C2").Select

                         ActiveWindow.FreezePanes = True



                        .Cells.EntireColumn.AutoFit

                        .Rows("1:1").Font.Bold = True



                        Call protect



               End With



                .SaveAs strNewPath & strFileName, Password:="ShiftDiff", FileFormat:=51

                .Saved = True

                .Close



            End With

            Set Wb = Nothing

        End If

    Next



Call Ludicrous(False)



    End Sub

The only problem is that it takes about 1-1.2 seconds to create, save, password protect, format, create two data validation lists, etc... Is this something I need to just deal with or is there a way to speed up these things? The Call Modules aren't much code at all, so the bulk of the improvements would be done in the code.

I have turned off all calculations, screen updates, etc... under the Ludicrous Mode moniker.

Is there a way to speed up the saving/password protecting? I know if you use a CopyAs save function into a template, that speeds it up a TON, but then you can't password protect. Any thoughts?

1. Performance measurement

"The only problem is that it takes about 1-1.2 seconds to create, save, password protect, format, create two data validation lists, etc"

Which portion of this 1000 to 1200 milliseconds corresponds to data retrieval? which one to formatting ranges or to saving? Try setting multiple timers each for a different task.

2. Variables and naming scheme

Perhaps this has nothing to do with performance, however, it affects the readability and appreciation of your algorithm. I see hard-coded variables like:

Dim BASEPATH As String: BASEPATH = "M:11-19-2018"

Consider using constants:

Const BASEPATH As String = "M:11-19-2018"

Const colManager = 3, colLogin As Long = 4, colEC As Long = 5

Consider using self-explanatory names. Insead of i, j, k, varArray() varArray2 etc, I would rather use:
iRow, iColm, iField, iRecord, iManager, iEmployee.
vManagers(), vManagers_trans(), the latter being the transpose of the former

3. Code simplification and efficiency

Instead of reffering frequently to the upper bound of 1st dimension, which is constant throughout the procedure, one may fix it like this:

Const NbFields As Integer = 19

Dim varArray() As Variant: ReDim varArray(1 To NbFields, 1 To 1)

For this line:

For j = 2 To .UsedRange.Rows.Count + 1

What is the point in retrieving data below the UsedRange? By definition, it's not USED, hence has no datum to get from.

I'm not sure how helpful are these assignments:

strEC = .Cells(j, colEC)

strManager = .Cells(j, colManager)

strLogin = .Cells(j, colLogin)

These strings will be overwritten by the next iteration. Only those of the last iteration will SURVIVE!

For the following loop:

For k = 1 To UBound(varArray, 1)

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

Next

I think it may be replaced by one assignment:

   varArray() = .Cells(1,1).Resize(1, NbFields).Value2

Even the If-Else may be optimized, so instead of:

For k = 1 To UBound(varArray, 1)

    If k = 1 Then

       varArray(1, x) = CStr(Format(.Cells(j, k), ...

    Else

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

    End If

why not simplifying things:

varArray(1, 1) = CStr(Format(.Cells(j, 1), ...

For k = 2 To NbFields

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

There's no good in repeating that conditional expression j*k times

. For sake of brieviety, I can't go more. You may correct me if I was wrong, as this is the point of a novice, which may or may not adhere to best practices.