Macro takes almost 3 minutes to run...How can I improve my sub routine to speed things up>

Itchy

New Member
Joined
Apr 9, 2016
Messages
5
Hello,

I have created a macro that has 2 subroutines that are taking way to long to run. The sub named Count_Number_Jobs (Engineers) takes about 20 seconds to run on my laptop. The sub named Count_Complexities_Per_Engineer (Engineers) takes 2 minutes 40 seconds to run. There are only around 300 to 500 rows of data.

The Count_Number_Jobs(Engineers) routine cycles through an array of 20 engineers and takes a count of how many jobs have been assigned to them each week over a period of 40 weeks. It takes that count and pastes them in another worksheet named "Chart Data". I autofilter by each engineers name in order to reduce the number of rows needed to cycle through. But in a nutshell the script is compiling data points for 20 engineers over 40 weeks. So the processed data would look like this:

EngineerWeek -5Week -4Week -3Week -2Week -1Week 0Week 1Week 2Week 3Week 4Week 5Week 6Week 7Week 8Week 9Week 10Week 11Week 12
Bill211
Jason113
Sue11
Nancy2

<tbody>
</tbody>

Bill has 2 jobs assigned at 6 weeks and 1 at week 7 and so on.

Code:
Sub Count_Number_Jobs(Engineers As Variant)

 Application.StatusBar = "Process 7 of 8 Begin"
 
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer

    Dim weekly_job_count   As String
    Dim job_count_array()  As Variant
    Dim Z As Long
    Dim j As Long
    
    Z = 1
    
    For Each Engineer In Engineers
            
            Worksheets("Raw Data").Range("K1").AutoFilter Field:=11, Criteria1:=Engineer
    
        For i = -5 To 35
        
        With Application
        
            Set Name = Worksheets("Raw Data").Columns("K")
            
           Set Weeks_Out = Worksheets("Raw Data").Columns("AC")
         
            weekly_job_count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i) 'name to test is the engineer and i is the week
            
            If weekly_job_count = 0 Then
            
                weekly_job_count = vbNullString
                
            End If
        
        End With
        
        ReDim Preserve job_count_array(j)
     
            job_count_array(j) = weekly_job_count
             
            j = j + 1
         
        Next
      
        j = 0
        Z = Z + 1
 
        Worksheets("Chart Data").Range("B" & Z & ":AP" & Z) = job_count_array()     'Paste in the job count for each engineer/each week in the chart data page
        
    Next
    
     Worksheets("Raw Data").ShowAllData
     
     SecondsElapsed = Round(Timer - StartTime, 2)
     MsgBox "This code ran  in " & SecondsElapsed & " Seconds", vbInformation
     
    
     Application.StatusBar = "Process 7 of 8 Complete"
  
End Sub


The Count_Complexities_Per_Engineer (Engineers) routine is a little more involved which is why it is taking much longer to run. This routine cycles through the 20 engineers for a 40 week period like the previous routine. However, in each week it is finding the count of complexity values that range from 1 to 10.

So the processed data would look like this:

EngineerWeek -5Week -4Week -3
123456789101234567891012345678910
Bill
Jason31311131

<tbody>
</tbody>


At -5 weeks Jason has 3 jobs at complexity value 1, 1 job at complexity value 2, 3 jobs at complexity value 4 and 1 job at complexity 9.

Code:
Sub Count_Complexities_Per_Engineer(Engineers As Variant)

    Application.StatusBar = "Process 8 of 8 Begin"
    
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer
      
    Dim Complexity_Count As String
    Dim complexity_count_array() As Variant
    Dim j As Long
    Dim l As Long
    Dim K As Long

    K = 2
    
    For Each Engineer In Engineers
    
        Worksheets("Raw Data").Range("K1").AutoFilter Field:=11, Criteria1:=Engineer
    
        For i = -5 To 35
        
            For l = 1 To 10
        
               With Application
               
                   Set Name = Worksheets("Raw Data").Columns("K")               'This is the column with the Engineers name
                   
                   Set Weeks_Out = Worksheets("Raw Data").Columns("AC")         'This is the column with the earliest start date
                   
                   Set Complexity_Value = Worksheets("Raw Data").Columns("R")   'This is the column with complexity values
                
                   Complexity_Count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i, Complexity_Value, l)
                   
                   If Complexity_Count = 0 Then
            
                        Complexity_Count = vbNullString
                        'Complexity_Count = ""
                
                   End If
                          
               End With
                           
                   ReDim Preserve complexity_count_array(j)
        
                    complexity_count_array(j) = Complexity_Count
                
                    j = j + 1
            
            Next
         
        Next
      
        j = 0
        Z = K + 1
        K = K + 1
        
        Worksheets("Complexity").Range("B" & Z & ":OU" & Z) = complexity_count_array()     'Paste in the complexity count for each engineer/each week in the chart data page
        
    Next
    
     Worksheets("Raw Data").ShowAllData
    
     SecondsElapsed = Round(Timer - StartTime, 2)
     MsgBox "This code ran  in " & SecondsElapsed & " Seconds", vbInformation
     
     Application.StatusBar = "Process 8 of 8 Complete"
     Application.StatusBar = ""

End Sub

I'm sure there is a better way to go about what I am doing. I just don't know what that looks like! I know there is a lot of overhead with looping through data but I don't know of a way around it in the situation that I have.
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
have a look at
Application.screenupdating = false at the beginning of a routine unless you need to see the progress flicker, set to True at the end of the relevant sub

otherwise what calculations are necessary to be undertaken whilst the macro runs

Conditional Format will cause delays
 
Upvote 0
So first could we pick off the low hanging fruit and then go from there? How are these being called? You are spending some overhead updating the screen and maybe a little pushing some calculations so to start off this should help a little. These should go in the calling Sub so they only get called once for both functions (I am assuming these are getting called as a pair?).


Code:
Public Sub TestMe()
 With Application 'Put at Start of calling Sub
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
 End With
 
 With Application 'Put at End of calling Sub
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With

Next do you have any event driven subs like Worksheet_Change? If so add these to the with statements.

Code:
  .EnableEvents = False'To start
  .EnableEvents = True'To end
 
Upvote 0
The sub routines are being called from the "main" sub. Unfortunately, I already have the disable, then enable calculation, and screen updating in the calling routine as you are suggesting. There are no event driven subs. There is a main sub that essentially calls 8 other subs that do different things. The first 6 subs process in milliseconds. The last 2 subs are causing the hangups.
 
Upvote 0
Good deal ok so that actually makes sense you have 40 loops in the first one and it takes 20 sec then you have 40 X 10 loops on the next that takes 2 min so the problem is in here

Code:
 With Application
  Set Name = Worksheets("Raw Data").Columns("K")               'This is the column with the Engineers name
  Set Weeks_Out = Worksheets("Raw Data").Columns("AC")         'This is the column with the earliest start date
  Set Complexity_Value = Worksheets("Raw Data").Columns("R")   'This is the column with complexity values
  Complexity_Count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i, Complexity_Value, l)
  If Complexity_Count = 0 Then
   Complexity_Count = vbNullString
   'Complexity_Count = ""
  End If
 End With
  ReDim Preserve complexity_count_array(j)
  complexity_count_array(j) = Complexity_Count
  j = j + 1
 Next

We can know that most of this could not be a problem if we get rid of that we are left with this guy

Code:
  Complexity_Count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i, Complexity_Value, l)

Right now you are feeding entire rows into this guy and I believe this is your problem if we can hone in on the cells you actually need to look through I believe this will help but I will have to look into it a bit to give you a stable solution.
 
Last edited:
Upvote 0
OK I am not 100% on this sorry so bear with me I believe this will help if I have done it correctly. Remove setting ranges from loops as they do not need to be there and only set to last cell. I don't have your workbook to test in and I am a bit fuzzy on the last cell so I hope this helps let me know how it goes


Code:
Sub Count_Number_Jobs(Engineers As Variant)

 Application.StatusBar = "Process 7 of 8 Begin"
 
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer

    Dim weekly_job_count   As String
    Dim job_count_array()  As Variant
    Dim Z As Long
    Dim j As Long
    
    Z = 1
    
    
    Set Name = Worksheets("Raw Data").Range("K1:K" & Worksheets("Raw Data").Range("K1").SpecialCells(xlCellTypeLastCell).Column)
            
    Set Weeks_Out = Worksheets("Raw Data").Range("AC1:AC" & Worksheets("Raw Data").Range("AC1").SpecialCells(xlCellTypeLastCell).Column)
    
    For Each Engineer In Engineers
            
        Worksheets("Raw Data").Range("K1").AutoFilter Field:=11, Criteria1:=Engineer
    
        For i = -5 To 35
        
        With Application
         
            weekly_job_count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i) 'name to test is the engineer and i is the week
            
            If weekly_job_count = 0 Then
            
                weekly_job_count = vbNullString
                
            End If
        
        End With
        
        ReDim Preserve job_count_array(j)
     
            job_count_array(j) = weekly_job_count
             
            j = j + 1
         
        Next
      
        j = 0
        Z = Z + 1
 
        Worksheets("Chart Data").Range("B" & Z & ":AP" & Z) = job_count_array()     'Paste in the job count for each engineer/each week in the chart data page
        
    Next
    
     Worksheets("Raw Data").ShowAllData
     
     SecondsElapsed = Round(Timer - StartTime, 2)
     MsgBox "This code ran  in " & SecondsElapsed & " Seconds", vbInformation
     
     Application.StatusBar = "Process 7 of 8 Complete"
     
End Sub

Sub Count_Complexities_Per_Engineer(Engineers As Variant)

    Application.StatusBar = "Process 8 of 8 Begin"
    
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer
      
    Dim Complexity_Count As String
    Dim complexity_count_array() As Variant
    Dim j As Long
    Dim l As Long
    Dim K As Long

    K = 2
    
    Set Name = Worksheets("Raw Data").Range("K1:K" & Worksheets("Raw Data").Range("K1").SpecialCells(xlCellTypeLastCell).Column)               'This is the column with the Engineers name
    
    Set Weeks_Out = Worksheets("Raw Data").Range("AC1:AC" & Worksheets("Raw Data").Range("AC1").SpecialCells(xlCellTypeLastCell).Column)       'This is the column with the earliest start date
    
    Set Complexity_Value = Worksheets("Raw Data").Range("R1:R" & Worksheets("Raw Data").Range("R1").SpecialCells(xlCellTypeLastCell).Column)   'This is the column with complexity values
    
    For Each Engineer In Engineers
    
        Worksheets("Raw Data").Range("K1").AutoFilter Field:=11, Criteria1:=Engineer
    
        For i = -5 To 35
        
            For l = 1 To 10
        
               With Application

                   Complexity_Count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i, Complexity_Value, l)
                   
                   If Complexity_Count = 0 Then
            
                        Complexity_Count = vbNullString
                        'Complexity_Count = ""
                
                   End If
                          
               End With
                           
                   ReDim Preserve complexity_count_array(j)
        
                   complexity_count_array(j) = Complexity_Count
                
                   j = j + 1
            
            Next
         
        Next
      
        j = 0
        Z = K + 1
        K = K + 1
        
        Worksheets("Complexity").Range("B" & Z & ":OU" & Z) = complexity_count_array()     'Paste in the complexity count for each engineer/each week in the chart data page
        
    Next
    
     Worksheets("Raw Data").ShowAllData
    
     SecondsElapsed = Round(Timer - StartTime, 2)
     MsgBox "This code ran  in " & SecondsElapsed & " Seconds", vbInformation
     
     Application.StatusBar = "Process 8 of 8 Complete"
     Application.StatusBar = ""

End Sub
 
Upvote 0
I believe your process can be speeded up considerably, but I am not 100% sure of your data layout and how it relates to the output tables you show. Is there anyway you can post a workbook containing "real" data (change sensitive information to fake information, but keep it real looking) along with actual calculated values for that data to DropBox or some other such free file sharing mechanism so we can see exactly what you have and exactly what you want to do with it?
 
Upvote 0
Ok, I made the changes to the code that HotRhodium suggested. Basically, moving the Set name and Set weeks out to the outside of the loop. By doing that the macro processed a little faster. I then tested it with changing the range to the last cell in the column that he suggested. The script was much faster. However, for some reason it didn't paste the data to the chart data and complexity data worksheets. I have attached a link to a dropbox folder that has the original workbook with the whole script. When you run the macro it will format data on the Raw data worksheet, add job counts to the chart data worksheet, add complexity count to the complexity worksheet. Then the scatter chart is linked to the data in the chart data and complexity count worksheets and will automatically update.
I really appreciate the help. I have been scratching my head with this for a while now!

https://www.dropbox.com/sh/s2wocqlzqttxima/AACe9kZ8g6x1XnH3uIr_piJYa?dl=0
 
Upvote 0
I made some tweaks to the code that HotRhodium suggested and now the entire macro runs in milliseconds! I am basically limiting the range as he suggested and the macro works like it should. I really want to thank all of you that helped me out with this. I have been trying to figure this our for some time and just couldn't figure out what was slowing things down so much. Once again thank you all for the help!

Code:
lastrow = Cells(Rows.Count, "Q").End(xlUp).Row              'Determine the last row of data
    
    Set Name = Worksheets("Raw Data").Range("K1:K" & lastrow)
            
    Set Weeks_Out = Worksheets("Raw Data").Range("AC1:AC" & lastrow)
    
    Set Complexity_Value = Worksheets("Raw Data").Range("R1:R" & lastrow)   'This is the column with complexity values
 
Upvote 0
Typo on my part I was calling for the last column not the last row. I believe you are going to be very happy when you run this. Pretty nice looking workbook hope this helps


Code:
Sub Count_Number_Jobs(Engineers As Variant)

 Application.StatusBar = "Process 7 of 8 Begin"
 
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer

    Dim weekly_job_count   As String
    Dim job_count_array()  As Variant
    Dim Z As Long
    Dim j As Long
    
    Z = 1
    
    
    Set Name = Worksheets("Raw Data").Range("K1:K" & Worksheets("Raw Data").Range("K1").SpecialCells(xlCellTypeLastCell).Row)
            
    Set Weeks_Out = Worksheets("Raw Data").Range("AC1:AC" & Worksheets("Raw Data").Range("AC1").SpecialCells(xlCellTypeLastCell).Row)
    
    For Each Engineer In Engineers
            
        Worksheets("Raw Data").Range("K1").AutoFilter Field:=11, Criteria1:=Engineer
    
        For i = -5 To 35
        
        With Application
         
            weekly_job_count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i) 'name to test is the engineer and i is the week
            
            If weekly_job_count = 0 Then
            
                weekly_job_count = vbNullString
                
            End If
        
        End With
        
        ReDim Preserve job_count_array(j)
     
            job_count_array(j) = weekly_job_count
             
            j = j + 1
         
        Next
      
        j = 0
        Z = Z + 1
 
        Worksheets("Chart Data").Range("B" & Z & ":AP" & Z) = job_count_array()     'Paste in the job count for each engineer/each week in the chart data page
        
    Next
    
     Worksheets("Raw Data").ShowAllData
     
     SecondsElapsed = Round(Timer - StartTime, 2)
     MsgBox "This code ran  in " & SecondsElapsed & " Seconds", vbInformation
     
     Application.StatusBar = "Process 7 of 8 Complete"
     
End Sub

Sub Count_Complexities_Per_Engineer(Engineers As Variant)

    Application.StatusBar = "Process 8 of 8 Begin"
    
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer
      
    Dim Complexity_Count As String
    Dim complexity_count_array() As Variant
    Dim j As Long
    Dim l As Long
    Dim K As Long

    K = 2
    
    Set Name = Worksheets("Raw Data").Range("K1:K" & Worksheets("Raw Data").Range("K1").SpecialCells(xlCellTypeLastCell).Row)               'This is the column with the Engineers name
    
    Set Weeks_Out = Worksheets("Raw Data").Range("AC1:AC" & Worksheets("Raw Data").Range("AC1").SpecialCells(xlCellTypeLastCell).Row)       'This is the column with the earliest start date
    
    Set Complexity_Value = Worksheets("Raw Data").Range("R1:R" & Worksheets("Raw Data").Range("R1").SpecialCells(xlCellTypeLastCell).Row)   'This is the column with complexity values
    
    For Each Engineer In Engineers
    
        Worksheets("Raw Data").Range("K1").AutoFilter Field:=11, Criteria1:=Engineer
    
        For i = -5 To 35
        
            For l = 1 To 10
        
               With Application

                   Complexity_Count = .WorksheetFunction.CountIfs(Name, Engineer, Weeks_Out, i, Complexity_Value, l)
                   
                   If Complexity_Count = 0 Then
            
                        Complexity_Count = vbNullString
                        'Complexity_Count = ""
                
                   End If
                          
               End With
                           
                   ReDim Preserve complexity_count_array(j)
        
                   complexity_count_array(j) = Complexity_Count
                
                   j = j + 1
            
            Next
         
        Next
      
        j = 0
        Z = K + 1
        K = K + 1
        
        Worksheets("Complexity").Range("B" & Z & ":OU" & Z) = complexity_count_array()     'Paste in the complexity count for each engineer/each week in the chart data page
        
    Next
    
     Worksheets("Raw Data").ShowAllData
    
     SecondsElapsed = Round(Timer - StartTime, 2)
     MsgBox "This code ran  in " & SecondsElapsed & " Seconds", vbInformation
     
     Application.StatusBar = "Process 8 of 8 Complete"
     Application.StatusBar = ""

End Sub
 
Upvote 0

Forum statistics

Threads
1,214,415
Messages
6,119,377
Members
448,888
Latest member
Arle8907

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top