Speed issues with running large spreadsheets and processing macros

[tomleitch]

Hi all,

General question here - just looking for pointers or suggestions really.

I have a fairly large spreadsheet - currently around 20,000 rows and 60 columns.

When this spreadsheet is run it runs very slowly on company laptops

It has macros in it that do quite a lot of things - some process data etc. I need these to be available when using the spreadsheet (i.e. excel online is no good for me).

Are there any solutions that I could look at in general to speed things up?

Is it possible to have some calculations etc that macros are doing running remotely maybe, or something like that?

Using filters on the spreadsheet is also very very slow.... but the macros are the main one that take the time.

I have the files hosted on a MS sharepoint site.


Any pointers or advice much appreciated.


Thanks
Tom

 

[Dave87]

at the start of your macro add the following codes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

at the end of your macro add the following codes to turn them all back on

Application.ScreenUpdating = True
Application.DisplayStatusBar = true

this should help a little

 

[tomleitch]

Thanks Dave, but I've already got that in the code. It just runs slow because it has a lot of calculations and things to do


Cheers
Tom

 

[RoryA]

Avoid reading or writing one cell at a time whenever possible. Read an entire range into a Variant in one go, producing a 2D array, process that, and then write it back to the range in one go. It is much, much faster.

 

[tomleitch]

Ah right, that sounds like it would definitely be worth having a read into... Many thanks RoryA

 

[tomleitch]

Although thinking about it I'm not sure if that would be possible - as the code needs to only change cells that are different from the last report entry - it then highlights them yellow and in some cases adds comments to the cells.


Regards
Tom

 

[RoryA]

You can still avoid doing some of that (eg the colouring) individually by building up one range object that contains all the cells and then manipulating that in one go.

If filters are slow, that's often a sign of inefficient formulas. Are they slow even with macros disabled?

 

[tomleitch]

Ok...That sounds like it could be worth looking into.

I'm a complete beginner with this kind of thing - and one of the board members, fluff, kindly helped me with some code to do what I was trying to do.... but as my spreadsheet and data collection has grown I have added more data and things into it. So I suspect it is now maybe quite inefficient from what you say.

Below is an excerpt from one of the (very scrappy) slow running macros... and if you could give me any pointers where I could read up on a better way to do it that would be much appreciated.

Thanks
Tom

With CreateObject("scripting.dictionary")
 

      For Each cl In ws2.Range("A2", ws2.Range("A" & Rows.count).End(xlUp))
        
      If Not .exists(cl.Value) Then .Add cl.Value, Array(cl.Offset(, 1).Value, cl.Offset(, 2).Value, cl.Offset(, 3).Value, cl.Offset(, 4).Value, cl.Offset(, 5).Value, cl.Offset(, 13).Value, cl.Offset(, 7).Value, cl.Offset(, 8).Value, cl.Offset(, 9).Value, cl.Offset(, 10).Value, cl.Offset(, 11).Value, cl.Offset(, 12).Value, cl.Offset(, 16).Value, cl.Offset(, 17).Value, cl.Offset(, 18).Value, cl.Offset(, 19).Value)
            
            
      Next cl
      



      
    '''''
    ' Remove cl if existing in archived
    

       For Each cl In Ws3.Range("A2", Ws3.Range("A" & Rows.count).End(xlUp))
       If .exists(cl.Value) Then .Remove (cl.Value)
       
       
       Next cl
       

       
      '*********************
     Dim Comm As Long
     
     
     
      For Each cl In ws1.Range("A10", ws1.Range("A" & Rows.count).End(xlUp))
      
     
            If .exists(cl.Value) Then
            
            
            
            'Check update Scheduler Comments to column A

            
            
85              If .Item(cl.Value)(14) <> "" Then

                If cl.Comment Is Nothing Then cl.AddComment
                
                If cl.Comment.Text <> .Item(cl.Value)(14) Then
               
                On Error Resume Next
86
                On Error GoTo 90
                 Cells(cl.Row, 1).Comment.Text Text:=.Item(cl.Value)(14)
                 Cells(cl.Row, 1).Comment.Shape.TextFrame.AutoSize = True
               If Cells(cl.Row, 1).Comment.Shape.Width > 200 Then
                     Cells(cl.Row, 1).Comment.Shape.Width = 200
                     Cells(cl.Row, 1).Comment.Shape.Height = 60
                     End If
                  End If
              End If
            
        
                'Check/update Desc and add location as comment
87                If Trim(UCase(cl.Offset(, 1).Value)) <> Trim(UCase(.Item(cl.Value)(0))) Then
                cl.Offset(, 1).Value = .Item(cl.Value)(0)
                
                    If .Item(cl.Value)(6) <> "" Then
                    If cl.Offset(, 1).Comment Is Nothing Then cl.Offset(, 1).AddComment
                    cl.Offset(, 1).Comment.Text Text:=.Item(cl.Value)(6)
                    cl.Offset(, 1).Comment.Shape.TextFrame.AutoSize = True
                        If cl.Offset(, 1).Comment.Shape.Width > 200 Then
                        cl.Offset(, 1).Comment.Shape.Width = 200
                        cl.Offset(, 1).Comment.Shape.Height = 60
                        End If
                    End If
                    cl.Offset(, 1).Interior.Color = rgbYellow
                End If
            
                'Check/Update Lead craft
                    If Trim(UCase(cl.Offset(, 8).Value)) <> Trim(UCase(.Item(cl.Value)(1))) Then
                    cl.Offset(, 8).Value = .Item(cl.Value)(1)
                    cl.Offset(, 8).Interior.Color = rgbYellow
                End If
            
            '   Check/Update CFW
                    If Trim(UCase(cl.Offset(, 7).Value)) <> Trim(UCase(.Item(cl.Value)(2))) Then
                    cl.Offset(, 7).Value = .Item(cl.Value)(2)
                    cl.Offset(, 7).Interior.Color = rgbYellow
                End If
            
            '   Check/Update Status
                    If Trim(UCase(cl.Offset(, 5).Value)) <> Trim(UCase(.Item(cl.Value)(3))) Then
                    cl.Offset(, 5).Value = .Item(cl.Value)(3)
                    cl.Offset(, 5).Interior.Color = rgbYellow
                End If
            
            'Check/Update priority
                    If Trim(UCase(cl.Offset(, 4).Value)) <> Trim(UCase(.Item(cl.Value)(4))) Then
                    cl.Offset(, 4).Value = .Item(cl.Value)(4)
                    cl.Offset(, 4).Interior.Color = rgbYellow
                End If
            
            
            ' Update Sched Start
                    If CLng(cl.Offset(, 12).Value) <> CLng(.Item(cl.Value)(5)) Then
                        If .Item(cl.Value)(5) <> "" Then
                        If cl.Offset(, 12).Comment Is Nothing Then cl.Offset(, 12).AddComment
                        cl.Offset(, 12).Comment.Text Text:="Last date: " & cl.Offset(, 12).Value
                        cl.Offset(, 12).Comment.Shape.TextFrame.AutoSize = True
                        If cl.Offset(, 12).Comment.Shape.Width > 200 Then
                        cl.Offset(, 12).Comment.Shape.Width = 200
                        cl.Offset(, 12).Comment.Shape.Height = 60
                    End If
                    End If
                    cl.Offset(, 12).Value = .Item(cl.Value)(5)
                    cl.Offset(, 12).Interior.Color = rgbYellow
                End If
  
  
            ' Update Parent ID
                    If Trim(UCase(cl.Offset(, 3).Value)) <> Trim(UCase(.Item(cl.Value)(7))) Then
                    cl.Offset(, 3).Value = .Item(cl.Value)(7)
                       If .Item(cl.Value)(8) <> "" Then
                        If cl.Offset(, 3).Comment Is Nothing Then cl.Offset(, 3).AddComment
                        cl.Offset(, 3).Comment.Text Text:=.Item(cl.Value)(8)
                        cl.Offset(, 3).Comment.Shape.TextFrame.AutoSize = True
                            If cl.Offset(, 3).Comment.Shape.Width > 200 Then
                            cl.Offset(, 3).Comment.Shape.Width = 200
                            cl.Offset(, 3).Comment.Shape.Height = 60
                        End If
                    End If
                    cl.Offset(, 3).Interior.Color = rgbYellow
                End If
     
     
            'Check/Update CAP Status
                    If Trim(UCase(cl.Offset(, 6).Value)) <> Trim(UCase(.Item(cl.Value)(9))) Then
                    cl.Offset(, 6).Value = .Item(cl.Value)(9)
                    cl.Offset(, 6).Interior.Color = rgbYellow
                End If
            
             'Check/Update SCE Status
                    If .Item(cl.Value)(10) = "Y" Then
                ''''''''''''''''''
                If .Item(cl.Value)(15) <> "" Then
                If cl.Offset(, 9).Comment Is Nothing Then cl.Offset(, 9).AddComment
47                If cl.Offset(, 9).Comment.Text <> .Item(cl.Value)(15) Then
48                        cl.Offset(, 9).Comment.Text Text:="Target Finish: " & .Item(cl.Value)(15)
49                        cl.Offset(, 9).Comment.Shape.TextFrame.AutoSize = True
50                            If cl.Offset(, 9).Comment.Shape.Width > 200 Then
                            cl.Offset(, 9).Comment.Shape.Width = 200
                            cl.Offset(, 9).Comment.Shape.Height = 60
                        End If
                  ''''''''''''''''
                    End If
                    End If
                    End If

                    
                    If Trim(UCase(cl.Offset(, 9).Value)) <> Trim(UCase(.Item(cl.Value)(10))) Then
                    cl.Offset(, 9).Value = .Item(cl.Value)(10)
                    cl.Offset(, 9).Interior.Color = rgbYellow
                End If
                
                'Check/Update Hours
                
                 If Trim(UCase(cl.Offset(, 14).Value)) <> Trim(UCase(.Item(cl.Value)(13))) Then
                    cl.Offset(, 14).Value = .Item(cl.Value)(13)
                    cl.Offset(, 14).Interior.Color = rgbYellow
                End If
                
                
                
                
                
                
                
            
                    '''''''''Add in
             
             'Update System Number - Disabled to speed up import and only imports on new jobs - also allows modding in sheet without updating
             
           ' Tagm = .Item(cl.Value)(12)
           ' mystr = onlyDigits(Tagm)
           ' mystr2 = Left(mystr, 3)

            'If Trim(UCase(cl.Offset(, 13).Value)) <> mystr2 Then
            'cl.Offset(, 13).Value = mystr2
            'cl.Offset(, 13).Interior.Color = rgbYellow
            'End If
            

            '''''''''''''/Add in
            
            
            
             'Check/Update WO Type
                    If Trim(UCase(cl.Offset(, 10).Value)) <> Trim(UCase(.Item(cl.Value)(11))) Then
                    cl.Offset(, 10).Value = .Item(cl.Value)(11)
                    cl.Offset(, 10).Interior.Color = rgbYellow
                End If
            
                .Remove (cl.Value)
            
            End If
            
            
            
         Next cl
          
   '''''''''''''CHK
   
   
      NxtRw = ws1.Range("A" & Rows.count).End(xlUp).Offset(1).Row
      For Each Ky In .keys

      
        If .Item(Ky)(3) <> "CAN" And .Item(Ky)(3) <> "COMP" And .Item(Ky)(3) <> "COMPD" And .Item(Ky)(3) <> "WCLOSE" Then ' And .Item(Ky)(5) < (Date + 365) Then ' Limit new jobs to within the next year only
         ws1.Range("A" & NxtRw).Value = Ky
         ws1.Range("A" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("B" & NxtRw).Value = .Item(Ky)(0)
         If .Item(Ky)(6) <> "" Then
         If ws1.Range("B" & NxtRw).Comment Is Nothing Then ws1.Range("B" & NxtRw).AddComment
         ws1.Range("B" & NxtRw).Comment.Text Text:=.Item(Ky)(6)
         ws1.Range("B" & NxtRw).Comment.Shape.TextFrame.AutoSize = True
         If ws1.Range("B" & NxtRw).Comment.Shape.Width > 200 Then
         ws1.Range("B" & NxtRw).Comment.Shape.Width = 200
         ws1.Range("B" & NxtRw).Comment.Shape.Height = 60
         End If
         End If
         ws1.Range("B" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("D" & NxtRw).Value = .Item(Ky)(7)
         If .Item(Ky)(8) <> "" Then
         If ws1.Range("D" & NxtRw).Comment Is Nothing Then ws1.Range("D" & NxtRw).AddComment
         ws1.Range("D" & NxtRw).Comment.Text Text:=.Item(Ky)(8)
         ws1.Range("D" & NxtRw).Comment.Shape.TextFrame.AutoSize = True
         If ws1.Range("D" & NxtRw).Comment.Shape.Width > 200 Then
         ws1.Range("D" & NxtRw).Comment.Shape.Width = 200
         ws1.Range("D" & NxtRw).Comment.Shape.Height = 60
         End If
         End If
         
         
         '''''''''''TCD Add in
         
                 If .Item(Ky)(10) = "Y" Then
                 If .Item(Ky)(15) <> "" Then
                 If ws1.Range("J" & NxtRw).Comment Is Nothing Then ws1.Range("J" & NxtRw).AddComment
                 ws1.Range("J" & NxtRw).Comment.Text Text:="Target Finish: " & .Item(Ky)(15)
                 ws1.Range("J" & NxtRw).Comment.Shape.TextFrame.AutoSize = True
                 If ws1.Range("J" & NxtRw).Comment.Shape.Width > 200 Then
                 ws1.Range("J" & NxtRw).Comment.Shape.Width = 200
                 ws1.Range("J" & NxtRw).Comment.Shape.Height = 60
                 End If
                 End If
                 End If
                 
                 
                 '/TCD
 
 
    'Functional comments addin
    
     If .Item(Ky)(14) <> "" Then
                 If ws1.Range("A" & NxtRw).Comment Is Nothing Then ws1.Range("A" & NxtRw).AddComment
                 ws1.Range("A" & NxtRw).Comment.Text Text:=.Item(Ky)(14)
                 ws1.Range("A" & NxtRw).Comment.Shape.TextFrame.AutoSize = True
                 If ws1.Range("A" & NxtRw).Comment.Shape.Width > 200 Then
                 ws1.Range("A" & NxtRw).Comment.Shape.Width = 200
                 ws1.Range("A" & NxtRw).Comment.Shape.Height = 60
                 End If
                End If
                
                
                '/FC
                
         
         
         
         ws1.Range("D" & NxtRw).Interior.Color = rgbYellow
        ws1.Range("E" & NxtRw).Value = .Item(Ky)(4)
        ws1.Range("E" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("F" & NxtRw).Value = .Item(Ky)(3)
         ws1.Range("F" & NxtRw).Interior.Color = rgbYellow
        ws1.Range("G" & NxtRw).Value = .Item(Ky)(9)
        ws1.Range("G" & NxtRw).Interior.Color = rgbYellow
        ws1.Range("H" & NxtRw).Value = .Item(Ky)(2)
        ws1.Range("H" & NxtRw).Interior.Color = rgbYellow
        ws1.Range("I" & NxtRw).Value = .Item(Ky)(1)
        ws1.Range("I" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("M" & NxtRw).Value = .Item(Ky)(5)
         ws1.Range("M" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("J" & NxtRw).Value = .Item(Ky)(10)
         ws1.Range("J" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("K" & NxtRw).Value = .Item(Ky)(11)
         ws1.Range("K" & NxtRw).Interior.Color = rgbYellow
         ws1.Range("O" & NxtRw).Value = .Item(Ky)(13)
         ws1.Range("O" & NxtRw).Interior.Color = rgbYellow
         
         
              '''''add in
         Tagm = .Item(Ky)(12)
        mystr = onlyDigits(Tagm)
        mystr2 = Left(mystr, 3)
         ws1.Range("N" & NxtRw).Value = mystr2
         ws1.Range("N" & NxtRw).Interior.Color = rgbYellow
        ''''''''/add in
        
       
        
  
        
         
         NxtRw = NxtRw + 1
       End If

'Add in functional comments to A column





        
      Next Ky
      
      
   End With

 

[RoryA]

OK, well right at the start, you're reading a whole load of cells, one by one. That will be slow. Much better to load the whole range into an array and process that. For example:

dim dataset
' read 20 column range into array
dataset = ws2.Range("A2", ws2.Range("A" & Rows.count).End(xlUp)).Resize(, 20).Value
With CreateObject("scripting.dictionary")
dim n as long
' loop through every row of the array
for n = lbound(dataset) to ubound(dataset)
   ' check if item in first column is already in dictionary
   If not .exists(dataset(n, 1) then
     .Add dataset(n, 1), Array(dataset(n, 2), dataset(n, 3), dataset(n, 4), dataset(n, 5), dataset(n, 6), dataset(n, 14), dataset(n, 8), dataset(n, 9), dataset(n, 10), dataset(n, 11), dataset(n, 12), dataset(n, 13), dataset(n, 17), dataset(n, 18), dataset(n, 19), dataset(n, 20))
   End If
Next n

 

[tomleitch]

Great - thanks RoryA... I'll give it a go