Speeding up execution time of worksheet-formatting code

Question

I've been writing some code that places some data in an empty worksheet and then formats the sheet by adding borders to all of the used cells. The code functions how it should perfect, but it takes a little bit of time to execute. I was wondering if there is any way I can speed up my code that I'm missing, because I don't know if there is a more efficient way to do what I've done.

Sub Report()

Application.ScreenUpdating = False
Sheets("Raw Data").Select
Application.Calculation = xlCalculationManual

Sheets("Raw Data").Unprotect

    Req = UniqueRequest()
    SheetForm = ReqSheetFormat()
    ReqColor = ReqColorCount()

Sheets("Raw Data").Protect

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Function ColSearch(Heading As String) As Integer
'Determines the column number of the desired heading

Sheets("Raw Data").Select
Sheets("Raw Data").Unprotect

    Dim myCol As Integer

    'Determines column number for desired string
    myCol = Sheets("Raw Data").Cells.Find(What:=Heading, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Column

ColSearch = myCol

End Function

Function UniqueRequest() As Long
'Creates dictionary full of unique request ID's and lists them in the "Request Results" sheet

    Dim d As Object, tmp2
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim i As Long
    Dim n As Long
    Dim x As Long
    Dim cllsct As Long
    Dim myReqIDCol As Integer
    Dim myNameCol As Integer
    Dim myTypeCol As Integer
    Dim myDescCol As Integer
    Dim myVerCol As Integer
    Dim myTstCol As Integer

        'Determines the last row and the last column of the table
        LastRow = Range("A" & Rows.count).End(xlUp).row
        LastColumn = Cells(1, Columns.count).End(xlToLeft).Column

        'Determines desired column number and stores it to a variable
        myReqIDCol = ColSearch("id")
        myNameCol = ColSearch("ownerFullname")
        myTypeCol = ColSearch("type")
        myDescCol = ColSearch("description")
        myVerCol = ColSearch("State")
        myTstCol = ColSearch("testResults")

        n = 1

        'Creates a dictionary filled with each unique value in the "id" column and stores the unique ID's to the "Request Results" sheet
        Set d = CreateObject("Scripting.Dictionary")
        For i = 2 To LastRow
            tmp2 = Cells(i, myReqIDCol).Value
            If tmp2 <> Empty Then
                If Not d.exists(tmp2) Then
                    d.Add tmp2, 1
                    n = n + 1
                    cllsct = Cells(i, myReqIDCol).Select
                    x = ActiveCell.row
                    NeedRev = DRev(x, n, myTypeCol, myDescCol, myTstCol, myVerCol)
                End If
            End If
            FullName = SelectName(x, n, myNameCol, myTypeCol)
        Next i

        'Pastes ID's in the "Request Results" sheet
        ThisWorkbook.Worksheets("Request Results").Range("A2").Resize(UBound(d.keys, 1) + 1).Value = Application.Transpose(d.keys)

End Function

Function ReqSheetFormat() As Long
'Formats "Request Results" sheet

    Dim i As Long
    Dim j As Long
    Dim LastRow As Long
    Dim LastColumn As Long

        'Creates header row for "Request Results" sheet
        With Sheets("Request Results")
            .Cells(1, 1).Value = "Request ID"
            .Cells(1, 2).Value = "Owner Name"
            .Cells(1, 3).Value = "Request Type"
            .Cells(1, 4).Value = "State"
            .Cells(1, 5).Value = "Design Review Required"
            .Cells(1, 6).Value = "Design"
            .Cells(1, 7).Value = "Design Review"
            .Cells(1, 8).Value = "Test Results"
        End With

        'Determines the last row and the last column of the table
        Sheets("Request Results").Select
        LastColumn = Cells(1, Columns.count).End(xlToLeft).Column
        LastRow = Range("A" & Rows.count).End(xlUp).row

        'Locks first row of sheet
        Rows("2:2").Select
        ActiveWindow.FreezePanes = True

        'Colors cells and formats sheet
        For i = 1 To LastRow
            If i >= 2 Then
                If Worksheets("Request Results").Cells(i, 5).Value = "Yes" And Worksheets("Request Results").Cells(i, 7).Value = "No" And Worksheets("Request Results").Cells(i, 7).Interior.Color <> RGB(255, 255, 0) Then
                    Worksheets("Request Results").Cells(i, 7).Interior.Color = 255
                ElseIf Worksheets("Request Results").Cells(i, 7).Value = "Yes" Then
                    Worksheets("Request Results").Cells(i, 7).Interior.Color = RGB(0, 176, 80)
                ElseIf Worksheets("Request Results").Cells(i, 7).Value = "No" And Worksheets("Request Results").Cells(i, 7).Interior.Color <> RGB(255, 255, 0) Then
                    Worksheets("Request Results").Cells(i, 7).Interior.Color = RGB(0, 176, 80)
                End If

                If Worksheets("Request Results").Cells(i, 4).Value = "Rejected" Then
                    Worksheets("Request Results").Cells(i, 5).Value = "N/A"
                    Worksheets("Request Results").Cells(i, 6).Value = "N/A"
                    Worksheets("Request Results").Cells(i, 7).Value = "N/A"
                    Worksheets("Request Results").Cells(i, 7).Interior.Color = RGB(0, 176, 80)
                    Worksheets("Request Results").Cells(i, 8).Value = "N/A"
                    Worksheets("Request Results").Cells(i, 8).Interior.Color = RGB(0, 176, 80)
                End If
            End If

            With Sheets("Request Results").Range(Cells(1, 1), Cells(1, LastColumn))
                .Borders(xlEdgeBottom).Color = 0
                .Borders(xlEdgeBottom).Weight = xlThick
            End With

            With Sheets("Request Results").Range(Cells(i, 1), Cells(i, LastColumn))
                .Borders(xlEdgeBottom).Color = 0
                .Borders(xlEdgeBottom).Weight = xlThin
            End With

            With Sheets("Request Results").Range(Cells(1, 1), Cells(1, LastColumn))
                .Borders(xlEdgeTop).Color = 0
                .Borders(xlEdgeTop).Weight = xlThick
            End With

            With Sheets("Request Results").Range(Cells(1, 1), Cells(LastRow, 1))
                .Borders(xlEdgeLeft).Color = 0
                .Borders(xlEdgeLeft).Weight = xlThick
            End With

            With Sheets("Request Results").Range(Cells(LastRow, 1), Cells(LastRow, LastColumn))
                .Borders(xlEdgeBottom).Color = 0
                .Borders(xlEdgeBottom).Weight = xlThick
            End With

            With Sheets("Request Results").Range(Cells(1, LastColumn), Cells(LastRow, LastColumn))
                .Borders(xlEdgeRight).Color = 0
                .Borders(xlEdgeRight).Weight = xlThick
            End With

            For j = 1 To (LastColumn - 1)
                With Sheets("Request Results").Range(Cells(i, 1), Cells(i, j))
                    .Borders(xlEdgeRight).Color = 0
                    .Borders(xlEdgeRight).Weight = xlThin
                End With
            Next j
        Next i

        'Aligns text of sheet to the left
        Sheets("Request Results").Select
        Columns("A:Z").HorizontalAlignment = xlLeft

        'Adds filter to the first row of sheet
        Range(Cells(1, 1), Cells(1, LastColumn)).Select
        Selection.AutoFilter

        'Disbales text wrapping for better formatting and autofits the cells
        Cells.WrapText = False
        ActiveSheet.Cells.Columns.AutoFit

End Function

I'm assuming it's the for loop that that's the cause for the slow execution time, but I'm not quite sure if there is a better way to set it up. Also, I don't have it shown in the code below, but I have Application.ScreenUpdating = False.

Answer 1

I only reviewed the first sub routine posted. I might get to the others at a later time.

Don't use PascalCase for variables, that should be for function, subs and classes. Single letter variables should be avoided. Also this is a personal preference but I like to put variable declarations right before to the initialization, especially with iterators for loops.

Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim LastColumn As Long

---

You request this sheet often.

Sheets("Request Results")

I recommend declaring a WorkSheet variables and setting it to this sheet. Also consider declaring a Constant for the name of the sheet. If you use use this sheet with other macros consider making separate function just to access the sheet.

Const REQUEST_SHEET_NAME As String = "Request Results"
Const REQUEST_BOOK_NAME As String = "your workbook's name"

Function GetRequestSheet() As WorkSheet

    Set GetRequestSheet = Workbooks(REQUEST_BOOK_NAME).Sheets(REQUEST_SHEET_NAME)

End Function

' In Sub
Dim requestSheet as Worksheet
Set requestSheet = GetRequestSheet()

This should be done for any other sheets.

---

You create your header statically, first I recommend setting a header variable as you access it more than once.

Dim headerRange as Range
Set headerRange = Range(requestSheet.Cells(1, 1), requestSheet.Cells(1, LastColumn))

Second, you should declare each field header as a constant and each column index as a constant. Consider linking them in a function that returns a "Scripting.Dictionary" Object structured so that {column_index -> field_name}.

Function GetHeaderDict() As Object

    Set GetHeaderDict = CreateObject("Scripting.Dictionary")
    GetHeaderDict.Add REQUEST_ID_COL, REQUEST_ID_HEADER
    ' ...
End Function

Printing the header to the sheet should be a separate Sub routine.

---

lastColumn = requestSheet.Cells(1, Columns.count).End(xlToLeft).Column
lastRow = requestSheet.Range("A" & Rows.count).End(xlUp).row

Also I don't know why people keep using the End method to count used rows and columns. I've used sheet.UsedRange.Rows.Count and sheet.UsedRange.Rows.Count. It considers data in all rows and columns not just the first. And I suspect it's faster, though I haven't tested it.

EDIT

See the ckuhn203's linked question about finding the last column and row. If your request sheets are guaranteed to be rectangular then your current method should be acceptable with prefixing Column.Count and Row.Count with your sheet.

lastColumn = requestSheet.Cells(1, requestSheet.Columns.count).End(xlToLeft).Column
lastRow = requestSheet.Range("A" & requestSheet.Rows.count).End(xlUp).row

You could also use UsedRange if you are confident that "A1" is filled and you want to include cells that are used in any way.

Otherwise, use the linked solution. Put it into a separate function and keep it in a separate module for future use.

---

The redundancies in the next loop are staggering.

• Declaring that requestSheet Object will reduce clutter and prevent redundant access of WorkSheets just to find the same sheet over and over again.
• Consider entering line breaks with the _ token to make this conditional more readable. This is a preference of mine. Others don't like to use _ as much as I do.
• Declare constants for your colors and column Indexes, it makes the code easier to maintain and let's readers know why the cell/color is significant.
• maybe even declare a range object and set the cells to it

Making some those suggestions turns this to

Dim some_cell as Range
Set some_cell = requestSheet.Cells(i, SOME_COL)

Dim other_cell as Range
Set other_cell = requestSheet.Cells(i, OTHER_COL)

If some_cell.Value = "Yes" _
And other_cell.Value = "No" _
And other_cell.Interior.Color <> COLOR_BAD Then

    other_cell.Interior.Color = COLOR_RED

ElseIf other_cell.Value = "Yes" Then

    other_cell.Interior.Color = COLOR_MARK

ElseIf other_cell.Value = "No" _
And other_cell.Interior.Color <> COLOR_BAD Then

    other_cell.Interior.Color = COLOR_MARK

End If

---

There are 4 with statements like this that have nothing to do with i and don't need to be looped over.

With Sheets("Request Results").Range(Cells(1, 1), Cells(1, LastColumn))
    .Borders(xlEdgeBottom).Color = 0
    .Borders(xlEdgeBottom).Weight = xlThick
End With

You could just move them out of the loop, but I would recommend also moving it to another function.

Sub GiveRangeBoldBorder(rng as Range)

    Dim edge As Variant
    For Each edge in Array(xlEdgeBottom, xlEdgeTop, xlEdgeLeft, xlEdgeRight)

        With rng.Borders(edge)

            .Color = 0
            .Weight = xlThick

        End With

    Next edge

End Sub

You also don't need to loop to add any borders. This will give thin borders to all cells in your used range.

With requestSheet.UsedRange.Borders

    .Color = 0
    .Weight = xlThin

End With

So now your formatting is just

' Give all cells thin black borders
With requestSheet.UsedRange.Borders

    .Color = 0
    .Weight = xlThin

End With

' Give header and UsedRange Bold borders
GiveRangeBoldBorder Range(requestSheet.Cells(1,1), requestSheet.Cells(1, lastColumn))
GiveRangeBoldBorder Range(requestSheet.UsedRange)

For i = 2 To LastRow

    ' Previous If/Else which should be it's own function

Next i

---

You have leftover code from when you recorded the macro. Step 1 after recording a macro is to clean it up. Any instance of Select needs to be replaced. Any instance of un-prefixed Rows, or Columns or Cells should be prefixed with your sheet variable.

headerRange.AutoFilter

With requestSheet

    .Range("A1", .Cells(lastRow, lastCol)).HorizontalAlignment = xlLeft
    With Cells

        .WrapText = False
        .Columns.Autofit

    End With

End With

Answer 2

Sub Report()

My other answer only covered the original question. I'd like to address some things about your "main" Report routine.

Naming

• Why are you short all your Funct names? It's not the 60's anymore. There aren't character limitations for this kind of thing anymore. Expand them out. If you're worried about a few keystrokes, don't be. That's what intellisense is for.

• Functions/Subs should have verb-noun names.

  Report => RunReport

  UniqueRequest => PopulateRequestSheet

  ReqSheetFormat => FormatRequestSheet

  ReqColorCount => GetColorCount

Scope

This first one isn't exactly about scope, but it's close enough to include here I guess.

• None of the functions you posted actually return anything. When you do this:

  Req = UniqueRequest()
  SheetForm = ReqSheetFormat()
  

  What actually happens is Req and SheetForm get set to Nothing. Your "functions" should be Subs called like this:

  Sheets("Raw Data").Unprotect
  
  PopulateRequestSheet
  FormatRequestSheet
  ReqColor = GetColorCount()
  
  Sheets("Raw Data").Protect
  

  You didn't post the other function, so I gave it the benefit of the doubt and assumed that it is returning a value.

• I really doubt that you'll be calling ReqSheetFormat from outside of Report. Right now it has a Public scope, which means it is visible through out the Workbook it's stored in. Report is the only Sub that should be publicly available. All others should be declared as Private.

  Public Sub RunReport
  
  Private Sub FormatRequestSheet
  
  Private Sub PopulateRequestSheet
  
  'etc
  

Error Handling

Anytime you muck around with ScreenUpdating or Calculation settings, you need to have an error handler. It's an absolute must. It can cause all kinds of confusion for the user if something goes wonky and an error is raised that terminates execution. Without the error handler, your user will be left with Calculation set to xlManual and SreenUpdating set to False.

The code:

Public Sub RunReport()
On Error GoTo ErrHandler

    Application.ScreenUpdating = False
    Sheets("Raw Data").Select
    Application.Calculation = xlCalculationManual

    Sheets("Raw Data").Unprotect

    PopulateRequestSheet
    FormatRequestSheet
    ReqColor = GetColorCount()

AlwaysExecute:

    Sheets("Raw Data").Protect

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

ErrHandler:
    Resume AlwaysExecute

End Sub

Answer 3

Filling in some gaps on ReqSheetFormat()

• You're inconsistently referencing "Request Results". Sometimes you use Sheets("Request Results") and other times Worksheets("Request Results"). The Sheets Collection can contain charts or worksheets, so it's probably safer to use Worksheets() for most applications. However, the first thing I did was assign it to a variable.

  Dim requestSheet as Worksheet
  Set requestSheet = ThisWorkbook.Worksheets("Request Sheet")
  

• i and j are traditionally used as loop counters, but row and col make more sense in this case.

• I agree that .Select should be avoided. For completeness' sake, you'll need to replace this:

  'Locks first row of sheet
  Rows("2:2").Select
  ActiveWindow.FreezePanes = True
  

  With this:

  With ActiveWindow
      .SplitColumn = 0
      .SplitRow = 1
  End With
  ActiveWindow.FreezePanes = True
  

• I also agree that the header logic should be moved into it's own function. Personally, I would have that function return the header range.

  Private Function WriteHeader(ws As Worksheet) As Range
  
      'Creates header row for "Request Results" sheet
      With ws
          .Cells(1, 1).Value = "Request ID"
          .Cells(1, 2).Value = "Owner Name"
          .Cells(1, 3).Value = "Request Type"
          .Cells(1, 4).Value = "State"
          .Cells(1, 5).Value = "Design Review Required"
          .Cells(1, 6).Value = "Design"
          .Cells(1, 7).Value = "Design Review"
          .Cells(1, 8).Value = "Test Results"
  
          Set WriteHeader = .Range(.Cells(1, 1), .Cells(1, 8))
      End With
  
  End Function      
  

• You already know that the lastColumn is 8. There's no reason to go looking for it. If the number of columns change, you'll need to change the WriteHeader function anyway. This is a case where your code should break if a change to the format is made. (This may or may not be controversial advice.)

  lastColumn = 8
  

• Your lastRow logic is correct. Don't change it, but do move logic that can be outside of the loop. Looping through each cell setting it's borders is crazy inefficient. This is the source of your slow down. Simplify it with this code. Place it after the loop and it executes once instead of 8 times per row.

  FormatBorders requestSheet.Range(requestSheet.Cells(1, 1), requestSheet.Cells(lastRow, lastColumn))
  ' .........
  
  Private Sub FormatBorders(rng As Range)
      With rng
          .BorderAround Weight:=xlThick, Color:=0
          .Borders(xlInsideHorizontal).Color = 0
          .Borders(xlInsideHorizontal).Weight = xlThin
          .Borders(xlInsideVertical).Color = 0
          .Borders(xlInsideVertical).Weight = xlThin
      End With
  End Sub
  

• Lastly, for readability, wrap the (almost) entire body of ReqSheetFormat in a With block so you don't have to keep typing requestSheet over and over and over.

Here's the code (without the suggested constants for the colors and what not):

Option Explicit

Function ReqSheetFormat() As Long
'Formats "Request Results" sheet

    Dim row As Long
    Dim col As Long
    Dim lastRow As Long
    Dim lastColumn As Long

    Dim requestSheet As Worksheet
    Set requestSheet = ThisWorkbook.Sheets("Request Results")

    Dim headerRange As Range
    Set headerRange = WriteHeader(requestSheet)

    'Locks first row of sheet
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

    With requestSheet
        'Determines the last row and the last column of the table
        lastColumn = 8
        lastRow = .Range("A" & .Rows.Count).End(xlUp).row

        'Colors cells and formats sheet
        For row = 1 To lastRow
            If row >= 2 Then
                If .Cells(row, 5).Value = "Yes" And .Cells(row, 7).Value = "No" And .Cells(row, 7).Interior.Color <> RGB(255, 255, 0) Then
                    .Cells(row, 7).Interior.Color = 255
                ElseIf .Cells(row, 7).Value = "Yes" Then
                    .Cells(row, 7).Interior.Color = RGB(0, 176, 80)
                ElseIf .Cells(row, 7).Value = "No" And .Cells(row, 7).Interior.Color <> RGB(255, 255, 0) Then
                    .Cells(row, 7).Interior.Color = RGB(0, 176, 80)
                End If

                If .Cells(row, 4).Value = "Rejected" Then
                    .Cells(row, 5).Value = "N/A"
                    .Cells(row, 6).Value = "N/A"
                    .Cells(row, 7).Value = "N/A"
                    .Cells(row, 7).Interior.Color = RGB(0, 176, 80)
                    .Cells(row, 8).Value = "N/A"
                    .Cells(row, 8).Interior.Color = RGB(0, 176, 80)
                End If
            End If
        Next row

        FormatBorders .Range(.Cells(1, 1), .Cells(lastRow, lastColumn))

        'Aligns text of sheet to the left
        .Columns("A:Z").HorizontalAlignment = xlLeft

        'Adds filter to the first row of sheet
        headerRange.AutoFilter

        'Disbales text wrapping for better formatting and autofits the cells
        .Cells.WrapText = False
        .Cells.Columns.AutoFit
    End With

End Function

Private Sub FormatBorders(rng As Range)
    With rng
        .BorderAround Weight:=xlThick, Color:=0
        .Borders(xlInsideHorizontal).Color = 0
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideVertical).Color = 0
        .Borders(xlInsideVertical).Weight = xlThin
    End With
End Sub

Private Function WriteHeader(ws As Worksheet) As Range

    'Creates header row for "Request Results" sheet
    With ws
        .Cells(1, 1).Value = "Request ID"
        .Cells(1, 2).Value = "Owner Name"
        .Cells(1, 3).Value = "Request Type"
        .Cells(1, 4).Value = "State"
        .Cells(1, 5).Value = "Design Review Required"
        .Cells(1, 6).Value = "Design"
        .Cells(1, 7).Value = "Design Review"
        .Cells(1, 8).Value = "Test Results"

        Set WriteHeader = .Range(.Cells(1, 1), .Cells(1, 8))
    End With

End Function