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]

Thank you so much for helping me with that code!!

I am really interested in your description of opening one book at a time, performing all the copies for that workbook then moving to the next workbook, the only problem is, I am not sure how I should structure the code. Could you give me some guidance please?

Thanks again ?

 

[offthelip]

The software structure would be like this, and it would be a complete rewrite, but this is the way I would do it, and the number of read and write accesses to the worksheet would exactly the same as the number of files that are needed. i.e only one read or one write for each file. There is only one sort per file, So I would expect it all to be very fast.
This does use the concept of a "Dictionary" which is a really good facility in VBA to generate a list of items without duplicates i.e a list of the different files needed. There are other ways this could be done.
1 Load tblcosting in a variant array (already done)

2: Loop through each row in the table:

2a: Check column 39, copy first name to a new dictionary ( Reporttracking dictionary)

2b: Check each row column 39if the name changes add it to the dictionary

3: in the same loop :

3a: Perform the logic to check whether Docyearname file is from column 36,37 or 42, add this name to a new variant array with the same number of elements as there are row in tblcosting. ( we are saving this to use later, let’s call it DYnames )

3b: Add each name to a second dictionary ( Docyearname dictionary)

3c: end the loop

We now have two list of filenames one for Reporttracking and one for Docyearname

So we deal with each of these separately:

Doing report tracking first:

4:Set up loop to loop round all the files in the Reporttracking dictionary ( might only be one)

Set up inside loop to loop through each row in tblcosting,

4a: If the name in column 39 is the same as the file name we have open then copy the inarr data to two new output arrays which have the same number of rows as inarr, one is for column A and the other is for column D and E . ( this assumes that we can’t write into columns B and C)

4b: at end of inside loop write output arrays to the reporttracking file

4c: Sort the file

4dc : go round the outside loop to do the next report tracking file

5:Set up loop to loop round all the files in the Docyearname dictionary ( might only be one)

Set up inside loop to loop through each row in tblcosting,

5a: If the name DYnames is the same as the file name we have open then copy the inarr data to one new output arrays which have the same number of rows as inarr, and 10 columns

5b: at end of inside loop write output arrays to the Docyearname file

5c: Sort the file

5dc : go round the outside loop to do the next docyearname file

 

[dpaton05]

I just tested your last batch of code and the saving of time is phenomenal!!!

To process 6 different entries for every monthly sheet from the start of this year until the end of next year now takes about 20 seconds.

I would immensely appreciate it if you could do the same thing you did for that other procedure where you added the comments above the lines of code so I can see what each line does.

 

[offthelip]

20 seconds is still fairly slow for vba, but is probably as good as it can be without the rewrite I outlined above. The reason it still takes 20 seconds is because we are still writing out to the worksheet every iteration. This exercise does show how much improvement can be made by avoiding interaction with worksheet. I will see if I get time to put comments in the code today, if not Monday

 

[dpaton05]

Thank you so much but if you haven't got time, don't worry about it.

 

[offthelip]

I have added some comments to my code to explain how I have used variant arrays to write the outputs to the worksheets

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
    Dim inarr As Variant
    Dim i As Long, kk As Long
        Application.ScreenUpdating = False
    Dim out1(1 To 1, 1 To 2) As Variant ' define a small output array of size 1 row and 2 columns
    Dim out2(1 To 1, 1 To 10) As Variant ' define a larger output array of size 1 row and 10 columns
    
    '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
inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value

For i = 1 To UBound(inarr, 1)
If inarr(i, 1) = "" Or inarr(i, 5) = "" Or inarr(i, 6) = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
  End If
Next i
'For Each tblrow In tbl.ListRows
For i = 1 To UBound(inarr, 1)
       
        'Define combo as the month to be recorded in
'        Combo = tblrow.Range.Cells(1, 26).Value
        Combo = inarr(i, 26)
        'If column 8 for the row is blank...
'        If Not tblrow.Range(1, 8).Value = "" Then
        If Not inarr(i, 8) = "" Then
            'worker variable is defined as the value in column 8 of the row
            'worker = tblrow.Range.Cells(1, 8).Value
            worker = inarr(i, 8)
        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)
        ReportTracking = inarr(i, 39)
            Select Case Site
                Case "Wes"
                    Select Case inarr(i, 6)
'                    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
                            DocYearName = inarr(i, 37)
                        Case Else
                            'DocYearName = tblrow.Range.Cells(1, 36).Value
                            DocYearName = inarr(i, 36)
                    End Select
                Case "Riv"
                    'Select Case tblrow.Range.Cells(1, 6).Value
                    Select Case inarr(i, 6).Value
                        Case "Ang Wes", "Ang Wa", "Ang Al", "Ang SC", "Yiri"
                            DocYearName = inarr(i, 42)
                        Case Else
                            DocYearName = inarr(i, 36)
                    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 ' NOTE DATA DOESN'T SEEM TO BE DEFINED!!
      
'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
           lasttrack = .Cells(Rows.Count, "A").End(xlUp).Row + 1 ' find the next empty row on the wstrack sheet
              '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
            .Range(.Cells(lasttrack, 1), .Cells(lasttrack, 1)) = inarr(i, 1)
            'this copies the YP name column in the tblCosting
'            tblrow.Range(, 4).Copy
            'this pastes it into column B of the report tracking file
            out1(1, 1) = inarr(i, 4) ' copy the 4th column of this row from tblcosting to the 1st column of the output array
'            .Range(.Cells(lasttrack, 2), .Cells(lasttrack, 2)) = inarr(i, 4)
               'this copies the YP name column in the tblCosting
'            tblrow.Range(, 5).Copy
            'this pastes it into column A of hours register file
            out1(1, 2) = inarr(i, 5) ' copy the 5th column of this row from tblcosting to the 2nd column of the output array
            .Range(.Cells(lasttrack, 2), .Cells(lasttrack, 3)) = out1 ' copy the small output array to the worksheet on row lasttrack
        End With
        With wsDst
          lastdst = .Cells(Rows.Count, "A").End(xlUp).Row + 1 ' find the next empty row on the wsdst sheet
          ' I am not sure what you are trying to do here but it can be improved
                'This sets column width of request number column so it can be read and is not xxxxx
              '  .Columns("C:C").ColumnWidth = 8 do this once at the end!!!
              
                '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
                
                For kk = 1 To 7
                out2(1, kk) = inarr(i, kk)         ' copy the 1st 7 colummns of this row from the tblcosting to the 1st 7 columns in the bigger output arrray
'                .Range(.Cells(lastdst, kk), .Cells(lastdst, kk)) = inarr(i, kk)
                Next kk
                ' this copies column 10 to column 8
                 out2(1, 8) = inarr(i, 10) 'copy column 10 this row from tblcosting to column 8 of output array
'                .Range(.Cells(lastdst, 8), .Cells(lastdst, 8)) = inarr(i, 10)
                
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                ' the comment doesn't seem t otie up wit the code here what are you doing??
                
'                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)"
               out2(1, 9) = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.)" 'write a formula into column 9 of output array
'                .Range(.Cells(lastdst, 9), .Cells(lastdst, 9)).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]"
                out2(1, 10) = "=RC[-1]+RC[-2]" ' write a formula into column 10 of output array
               ' .Range(.Cells(lastdst, 10), .Cells(lastdst, 10)).Formula = "=RC[-1]+RC[-2]"
               .Range(.Cells(lastdst, 1), .Cells(lastdst, 10)) = out2 ' this writes all 10 columns in one go to the next empty row
                'Adds currency formatting to total ex gst column
 '               .Columns(8).NumberFormat = "$#,##0.00" do this at the end
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
  
   
                'sort procedure copied from vba
                'DO NOT DO THIS SORT ON EVERY ITERATION IT WILL BE MAJOR CAUSE OF YOUR TIME PROBLEM
        End With
'    Next tblrow
    Next i
          With wsDst
            lr = .Cells(Rows.Count, "A").End(xlUp).Row ' line added to make sure you sort the whole sheet if rows have been added
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Columns("C:C").ColumnWidth = 8
        End With
        
                With Workbooks(DocYearName).Worksheets(Combo)
                  lr = .Cells(Rows.Count, "A").End(xlUp).Row ' line added to make sure you sort the whole worksheet
                    'set range to sort of A3 to AO
                    .Sort.SortFields.Add Key:=Range("B4:B" & lr) ' line added since you hadn't put a sort column in I chose B!!!
                    .Sort.Header = xlYes
                    .Sort.MatchCase = False
                    .Sort.Orientation = xlTopToBottom
                    .Sort.SortMethod = xlPinYin
                    .Sort.Apply
                End With
    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]

Thank you, your assistance has been greatly appreciated. Could you send me a PM, with an outline of what you did please?

I would also love to learn how to make your other method of completing this project that you mentioned in post 42 that you thought would be so much faster.

 

[offthelip]

You wanted more details of what I did to speed up your code, the first and most important:
I looked through your code and noticed that you were access two worksheets many times in a loop, this is very very slow, so it is usually very easy to speed this sort of code up by using variants.
it is very easy to identify statements that access the worksheet they usually have got one of the following words "Range" , "Cell" , "Columns" , "Rows" in the statement. Remember each access costs time.
So at the start of your code you loop through the whole tbl with this statement

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

the if statement accesses the worksheet 3 times!! and this is before you start the main loop.
So all I did was copy the data from tblcosting into a variant array (called inarr) using this line of code:

inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value

and then every time you referred to the table I changed the reference to the variant array, to do this I used a loop count that just looped through the whole table because the variant array is automatically sized to the size of the tabel ( clever EXcel)
so the two lines of code chage to:

For i = 1 To UBound(inarr, 1)
If inarr(i, 1) = "" Or inarr(i, 5) = "" Or inarr(i, 6) = "" Then

Then every other reference to the tbl is changed as well.
The second step was to use a variant array for the outputs
If you look at your code from the "with wsTrack down to the "Next tblrow"
Every single line is accessing the worksheet, so all I have done is combine some of the lines of code which write outputs to a single cell into lines of code that build up the whole row of the worksheet and then writes the whole row out.

The only other thing I did was move the sort out of the loop, this is because sorting is a slow process which accesses the worksheet many times during the sort and to is terrible thing to do in a loop. Avoid if at all possible.

In terms of what I outlined in post 42, to speed it up even further, that post describes the structure in the best way I can. The next step would be to write the code, if there are any questions about what I mean do ask.

 

[dpaton05]

Thankyou for your ongoing help!

I am sorry to be a big nuisance but I would also really appreciate if you could write the lines of code next to each description from post 42. As with the other comments you added, it takes me so much longer to understand things as I have a disability. I find it so much easier to read the explanations when I am looking at the working code.

Thanks

 

[dpaton05]

I accidentally hit post while I was typing this message