Speeding up my code

[dpaton05]

I have a table in my spreadsheet that goes from A-AP. It has visible columns up to column Q. From R to AP are hidden columns. The extra columns are hidden and they are just to work out certain information based on the data entered in the visible columns. For instance, I have a date that is entered in column A and in column Z I have this formula to work out the month the transaction needs to be recorded in based on the requirements of my workplace.

=IF(MONTH(A5)=6,"June",TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "mmmm"))

In column AA

=TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "yyyy")

That is just 2 of the columns. The table ends at the column AP with other formulas that derive their data from the visible cells

I have a copy procedure that looks at every row in the table and copies information from the row to 2 separate documents. These separate documents are financial year documents, broken up into monthly sheets. Parts of each row in the table are copied to monthly sheets in the 2 documents. For about 100 rows entered in the table, in takes around 5 minutes to run the code. This doesn't seem like I have developed it in the most efficient manner and I am sure it can be executed much faster.

I am still learning vba, so when I had something working, I didn't want to break it again so I left it. Other people helped me with most of it too so I couldn't change parts due to not knowing how.

I am not sure if it can be run faster but could someone look at my code and give a few ideas on how I could speed it up please? I have been told that the more you need to interact with the worksheet, the more it slows down. Maybe I should try and move alot of the additional, hidden columns into vba so it doesn't need to interact with the worksheet so much?

Here is my copy procedure.
You may notice that there is code relating to an hours register file that is commented out. I do not need it anymore at the moment but I may need it later.

Sub cmdCopy()
'On Error GoTo ErrorMsg
    Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
    Dim Combo As String, sht As Worksheet, tbl As ListObject
    Dim LastRow As Long, DocYearName As String, Site As String, lr As Long, HoursRow As Long
    Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
        Application.ScreenUpdating = False
       
    'assign values to variables
    Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    'Check if each row has a date, service and requesting organisation
    For Each tblrow In tbl.ListRows
        If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
        End If
    Next tblrow
    For Each tblrow In tbl.ListRows
        'Define combo as the month to be recorded in
        Combo = tblrow.Range.Cells(1, 26).Value
        'If column 8 for the row is blank...
        If Not tblrow.Range(1, 8).Value = "" Then
            'worker variable is defined as the value in column 8 of the row
            worker = tblrow.Range.Cells(1, 8).Value
        Else
            'otherwise, "not allocated" is assigned to the worker variable.
            'this is used in the hours register to identify which sheet to place the hours in
            worker = "Not allocated"
        End If
        'defines HoursRegister as the hours register filename that is stored in column 38 for the row
'HoursRegister = tblrow.Range.Cells(1, 38)
        'defines ReportTracking as the report tracking filename that is stored in column 39 for the row
        ReportTracking = tblrow.Range.Cells(1, 39)
            Select Case Site
                Case "Wes"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
                            DocYearName = tblrow.Range.Cells(1, 37).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select
                Case "Riv"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
                            DocYearName = tblrow.Range.Cells(1, 42).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select

            End Select
        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
'If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
        If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
'Set wsHours = Workbooks(HoursRegister).Worksheets(worker)
        Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
        Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
        lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
       
        'Copy the pricing cells from the quoting tool to the allocation sheet for use in calculating late cancels
        Workbooks(DocYearName).Worksheets("sheet2").Range("A4:E12").Value = Data.Range("A4:E12").Value
       
'With wsHours
      'this copies the date column in the tblCosting
    'HoursRow = .Range("A" & Rows.Count).End(xlUp).Row
    'tblrow.Range(, 1).Copy
    'this pastes it into column A of hours register file
    '.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
      'this copies the YP name column in the tblCosting
    'tblrow.Range(, 4).Copy
    'this pastes it into column B of hours register file
    '.Range("B" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
       'this copies the YP name column in the tblCosting
    'tblrow.Range(, 3).Copy
    'this pastes it into column A of hours register file
    '.Range("C" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
       'this copies the hours column in the tblCosting
    'tblrow.Range(, 9).Copy
    'this pastes it into column A of hours register file
    '.Range("D" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'End With
        With wsTrack
              'this copies the date column in the tblCosting
            tblrow.Range(, 1).Copy
            'this pastes it into column A of hours register file
            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
            'this copies the YP name column in the tblCosting
            tblrow.Range(, 4).Copy
            'this pastes it into column B of the report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the YP name column in the tblCosting
            tblrow.Range(, 5).Copy
            'this pastes it into column A of hours register file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteFormulasAndNumberFormats
        End With
        With wsDst
                'This sets column width of request number column so it can be read and is not xxxxx
                .Columns("C:C").ColumnWidth = 8
               
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range.Resize(, 7).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range(, 10).Copy
               
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
               
                'Overwrites the numbers pasted to column I with a formula
                .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                'Overwrites the numbers pasted to column L with a formula
                .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
                'Adds currency formatting to total ex gst column
                .Columns(8).NumberFormat = "$#,##0.00"
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
   
    
                'sort procedure copied from vba
                wsDst.Sort.SortFields.Clear
                wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        With Workbooks(DocYearName).Worksheets(Combo).Sort
                            'set range to sort of A3 to AO
                            .SetRange Range("A3:AO" & lr)
                            .header = xlYes
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                        End With
        End With
    Next tblrow
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
Exit Sub

'ErrorMsg:
'    Select Case Err.Number
'        Case 53
'            MsgBox "Enable macros needs to be selected"
'    End Select
End Sub

 

[dpaton05]

I tried to move the sorting procedure outside of the loop and that did speed it up a bit, but I wasn't quite sure how to go about your ideas in post 18. Could you help me with the coding I need to do in order to further speed it up please?

 

[Michael M]

Hi Dave
I can't help at the moment, but I would like to mention that saving a fraction of a second by speeding up code, sometimes comes with the downside that the end user / coder isn't able to debug or insert new code when required......I have found unless I FULLY understand what the code is doing, I don't mess with it for the sake of a fraction of time....BTW,How long IS the code taking to run ?

 

[dpaton05]

Well my original code was taking about 5 minutes to process about 100 entries. Do you think that would be enough just to move the sorting out of loop?

 

[Michael M]

How long does it take after you move the sorting outside the loop ??

 

[offthelip]

Hi Dave
I can't help at the moment, but I would like to mention that saving a fraction of a second by speeding up code, sometimes comes with the downside that the end user / coder isn't able to debug or insert new code when required......I have found unless I FULLY understand what the code is doing, I don't mess with it for the sake of a fraction of time....BTW,How long IS the code taking to run ?

While I agree with you about not being worth not saving a fraction of a second, the sort of changes which I have been trying to implement are likely to save not milliseconds or seconds much more likely to be minutes, So are worth doing. Secondly if you look at the changes to the Op code, there is a one to one correlation between the original lines of code and the code I have written, so the changes are not likely to make the code more difficult to understand, Most of the lines of of code are actually a lot shorter so really they are easier to read. My other suggestion of moving a sort outside a loop is a basic time saving move and obviously doesn't make the code more difficult to understand,. Learning how to write fast code by using a few easily understood ideas ( such as variant arrays) is really worth doing because it can often get a 5 minute macro to run in less than a second. The OP code had over 30 accesses to the worksheet every iteration, just to give you an idea about how time can be saved and how easily, compare these two macros which functionally do the same thing ( it writes a value to each cell in the range A1:D100) i.e 400 cells. the fast macro runs in 15 millisec on my machine while the slow macro take 640 millisec.. i.e 42 time as long!! i.e you save a second every time you save 800 worksheet accesses, not difficult in a loop

Sub slow()
Dim myrange As Range
Dim cell As Range
Dim elasped As Double

starttim = Timer()
i = 1
Set myrange = Range("A1:D100")
For Each cell In myrange
cell = i + 1
i = i + 1
Next cell
elaspsed = 1000 * (Timer() - starttim)
MsgBox elaspsed & " millisec"


End Sub

Sub fast()
Dim myrange As Variant
Dim cell As Range
Dim elasped As Double

starttim = Timer()
i = 1
myrange = Range("A1:D100")
For k = 1 To UBound(myrange, 1)
   For j = 1 To UBound(myrange, 2)
     myrange(k, j) = i + 1
      i = i + 1
   Next j
Next k
Range("A1:D100") = myrange

elaspsed = 1000 * (Timer() - starttim)
MsgBox elaspsed & " millisec"


End Sub

 

[offthelip]

I tried to move the sorting procedure outside of the loop and that did speed it up a bit, but I wasn't quite sure how to go about your ideas in post 18. Could you help me with the coding I need to do in order to further speed it up please?

Have you tried the code that I posted in post #16??
Can you post your current code.
what are the relative times now?

 

[dpaton05]

I did try it at work today but I was getting an error with a line just below the with wsDst but I thought you hadn't finished it yet. From memory, I think it was a overflow or a generic error. I will have a look tomorrow and send my code I now have.

 

[offthelip]

I think the code is complete, however that depends on my understanding of your problem, when you get the error make sure you record the values of i, lr, kk inarr , and anything else on the line that has the error. if you are unsure how to do this , brush up on using the VBA debugger

 

[Michael M]

@offthelip
I fully agree with all your comments and certainly didn't mean to take you to task over your code, but sometimes posters have trouble understanding the changes (variant arrays) and have trouble at a later date trying to change said code when it is new to them. For some of us, especially old timers like myself, changes in written code is hard to comprehend.......

 

[dpaton05]

I agree Michael that trouble can run into if you don't understand the code but during my learning process, I have encountered much code I do not understand at first but have found I am better able to understand it if I can see the working version of the code.