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

 

[offthelip]

I have been told that the more you need to interact with the worksheet, the more it slows down.

Yes this is true and your code in interacting with the worksheet a huge amount which means there is plenty of scope to speed it up very easily.
If you load your table into a variant array you can do all the checking which you are currently doing directly on the table in memory which since you do this twice will save sometime. This code shows you how to change this code to use varaint arrays:

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


using varaint array
[CODE=vba]Dim inarr As Variant
inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value
    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 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

I notice further down you are coping and pasting single cells on a row by row basis, specfying formula and number formats. This is very slow, the fast way to do this depends on whethere you are copying to formula or the numbers. You can load the formula in a range into a variant array and you can load the values in a range into a variant array. Unfortunately you can't load the formatting for a range into a variant . So the quick to do you copies is to load the values or the formula into a variant array ( depend which you want to copy) and then copy from the variant array. Then only after the loop is finished apply the formatting to the worksheet to the whole column

 

[dpaton05]

Thanks for the reply. I am new to vba so not sure how it works very well yet. I am having a little trouble seeing how to incorporate your code into mine.

You set inarr as a variant variable. What are you setting inarr to? You can have a .value of a cell but does .value of a table assign the whole table to the variable?

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

I don't understand this line of code, could you explain it to me please?

For i = 1 To UBound(inarr, 1)

I also don't understand how the above line of code relates to this line, could you also explain that please?

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

I notice further down you are coping and pasting single cells on a row by row basis, specfying formula and number formats. This is very slow, the fast way to do this depends on whethere you are copying to formula or the numbers. You can load the formula in a range into a variant array and you can load the values in a range into a variant array. Unfortunately you can't load the formatting for a range into a variant . So the quick to do you copies is to load the values or the formula into a variant array ( depend which you want to copy) and then copy from the variant array. Then only after the loop is finished apply the formatting to the worksheet to the whole column

With the last paragraph you wrote about my specifying formula and number formats, I only want to copy the numbers but I am unsure how to put all your advice together.

Can you tell me more about loading the formula in a range and the values in a range into a variant array and how I might be able to use them please?

Any advice on code I could use to put it all together and implement your advice, would be appreciated.

Thanks.

 

[offthelip]

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

This line of code loads all of the data from your table into a two dimensional variant array, if your table was three columns wide and 20 rows , then the array automatically is defined as the same size, but note rows are the first index and columns the second index. So the top left value in your table in loaded into the element inarr(1,1), the next element to the right of that is in inarr(1,2) and the value one row down on the left hands side is in inarr(2,1). So inarr is an exact match for the data in your table, so you can refer to it just like you can range, but you must use numerical indexing not letters and number.

For i = 1 To UBound(inarr, 1)

This line of code is setting up and index loop where the value of I starts at 1 goes up increments of 1 to a maximum value which is defined by Ubound(inarr,1) . This function returns the maximum array for the dimension specified . So in my example above for a table 3 columns wide and 20 rows. Ubound(inaar,1) will return the number 20. Ubound(inarr,2) will return the number 3. This is the equivalent of your:

For Each tblrow In tbl.ListRows

but the way you do it for arrays

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

This line of code is checking the values in columns 1 , 5 and 6 in the row of the table given by the value in i.
this is exactly equivalent to your line of code where you have selected a table row and then picked out the individual cells for row. So your reference at the start of each value, "tblrow" is doing exactly the same as I am doing with the index i

If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then

If you only want to copy the values it makes the whole think much easier. this means you just need to copy all the values into a variant array. You can then define another variant array as you output and copy the valuers from one variant array to the other and then write the out put array the worksheet. I would expect this to be at least 1000 times faster than the way you are doing. ( Not a typo I mean at least 1000)
The first line of this comment shows you how to load a variant array from the table.
to load a variant array from a range:

inarr=Range(cells(1,1),cells(20,3))

This loads cells A1:B20 into inarr
to write an array back to the worksheet:

Range(cells(1,10),cells(20,13)=inarr

this will write the same array back to J1:L20

 

[dpaton05]

Thanks for that. The only problem is that I have a very poor memory and struggle relating different bits of code together if they are broken up, even with explanations.

I have moved the column format code outside of the loop and that has sped it up slightly but it is still not fast. I know that arrays would be the way to go but I really struggle with learning new things.

I think that one of the best ways I learn is by seeing what I have done alongside what I am trying to learn, just as you started doing in post 2. Would you be able to do that for the rest of my procedure please?

 

[montecarlo2012]

Hi, dpaton05, I am not an expert on coding, but let me give you advise how to get help in this great forum, your code looks like to big to go through so I copy and trim for you, so now looks like easier to workout. check:

Sub DPATON05()
            Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker$, wsSrc As Worksheet, tblrow As ListRow
            Dim Combo$, sht As Worksheet, tbl As ListObject
            Dim LastRow&, DocYearName As String, Site As String, lr&, HoursRow&, RowColor&, w As Window, r&, HoursRegister$, ReportTracking$
            
            Application.ScreenUpdating = False
            
                              Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
                              Set sht = ThisWorkbook.Worksheets("Costing_tool")
                              
                              Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
                              
                                    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
                                             
                                                               Combo = tblrow.Range.Cells(1, 26).Value
                                                                              If Not tblrow.Range(1, 8).Value = "" Then
                                                                                          worker = tblrow.Range.Cells(1, 8).Value
                                                                                          Else
                                                                                          worker = "Not allocated"
                                                                              End If
                                                               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 & ".xl"
                                                                                       If Not isFileOpen(ReportTracking & ".xlsm") Then
                                                                                       Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
                                                                                       
                                                                                       
                                                               Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
                                                               Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
                                                               
                                                               lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
                                                               
                                                               Workbooks(DocYearName).Worksheets("sheet2").Range("A4:E12").Value = Data.Range("A4:E12").Value
                                                                                       With wsTrack
                                                                                                      tblrow.Range(, 1).Copy
                                                                                                      .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                                                                                                      tblrow.Range(, 4).Copy
                                                                                                      .Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteFormulasAndNumberFormats
                                                                                                      tblrow.Range(, 5).Copy
                                                                                                      .Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteFormulasAndNumberFormats
                                                                                       End With
                                                                                       With wsDst
                                                                                                         .Columns("C:C").ColumnWidth = 8
                                                                                                         tblrow.Range.Resize(, 7).Copy
                                                                                                         .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                                                                                                         tblrow.Range(, 10).Copy
                                                                                                         .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                                                                                                         .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                                                                                                         .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
                                                                                                         .Columns(8).NumberFormat = "$#,##0.00"
                                                                                                         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
                                                                                                                        .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
End Sub

I think who ever make the comments when to far, so I eliminated and dented better.
I hope next reader will fill better to check it out.

 

[dpaton05]

I made the comments. They were to help me in identifying what each part did as I am not very good at writing vba yet so I need to document what each part does, otherwise I will forget.

 

[montecarlo2012]

dpaton05 you are not alone, you are doing better than me, I try to study at least 1 hour a day, but until now the only good place to learn is here, no the books no youtube, here is really good.
the last part of your code is a macro, maybe if you try to do some kind of loop, instead of all that with.. end with and formats etc. may be speed up a little.

 

[offthelip]

I have updated your original code to change more of it to use a variant array. I have done this by commenting out your code and adding the equivalent line. The only part which I haven't done is the bit at the end with the wsDST sheet, . This is because I don't understand what you are doing here. Can you describe what you want done, because I think it can be done a much better way.

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
   
        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
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
      
'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
            .Range("A" & Rows.Count).End(xlUp).Offset(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
            .Range("A" & Rows.Count).End(xlUp).Offset(, 1) = 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
            .Range("A" & Rows.Count).End(xlUp).Offset(, 2) = inarr(i, 5)
        End With
        With wsDst
          ' 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
                .Range("A" & Rows.Count).End(xlUp).Offset(kk) = inarr(i, kk)
                Next kk
                '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)"
                '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
                'DO NOT DO THIS SORT ON EVERY ITERATION IT WILL BE MAJOR CAUSE OF YOUR TIME PROBLEM
                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
    Next i
    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

 

[offthelip]

@montecarlo2012 " Hi, dpaton05, I am not an expert on coding, but let me give you advise how to get help in this great forum, your code looks like to big to go through so I copy and trim for you, so now looks like easier to workout. check: "
Don't ever delete comments they are the most useful part of the code, because it usually describes what the intention of the programmer was even if the code doesn't do what the comment states, so if you find a bit of code where the comments don't tie up with the actually code it immediately highlights a possible problem area. As I have just found in the OP code.