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 thought I would have a go at this but there is a lot I don't understand.

a.

For i = 1 To UBound(inarr, 1)

this line of code starts the counter at 1, it will go until the upper limit in terms of rows in the first column of the array stored in inarr?

If it was UBound(1, inarr), the code would cycle through all the columns, correct?

Does it step through by 1 or does in 1 in (inarr, 1) refer to the first column?




Regarding your method in post 42, this is broken up into the points from the post

1. I understand this part loading the table/range into a variant, which becomes an array. Anyway, this bit has already been done.


2. Looping through each row in the table in the array, is it done with the following code?
For i = 1 To UBound(inarr, 1)?


2a. Check column 39, copy first name to a new dictionary ( Reporttracking dictionary)
How do you check column 39 and add it to new dictionary? I looked at this but I wasn't sure what to do.


2b. Check each row column 39if the name changes add it to the dictionary
Could you help me with the syntax to do this bit also please?


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 )
Do I include the logic I used to find the DocYearName filename?


My code/logic was

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

I am not sure how to then add this to a variant array with the same number of rows as in tblCosting, could you please help me with that?

I also don't know what to do with DYnames?



3b. Add each name to a second dictionary ( Docyearname dictionary)
This step involves adding this to a separate dictionary. How do you do this and what is the point?



3c: I understand that at the end of this, I write next to go to the next row and at the end of the rows, the loop is ended.







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,

With this step, I thought that you would need to loop through the table first but can you help me please as I have no idea how to setup the syntax for these bits?



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)
Again, please can you help me with the syntax to code this bit as I have no idea how to write this bit?



4b: at end of inside loop write output arrays to the reporttracking file
I don't know how to do this, please can you help me with it?



4c: Sort the file
Do I use the standard sort code for this?

         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

4dc : go round the outside loop to do the next report tracking file
From this point onwards, I do not know how to code any of these, except 5c. Actually, I don't think I have known much of the code required so far. Can you please help me with the syntax for them?


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
Do I use the standard sorting code as in 4c above or should I use different sort code using arrays or something similar?



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



Thank you again for helping me

 

[offthelip]

You need to do a bit of googling: google "Ubound VBA" to find out how Ubound works, it is not as you describe
Google "Excel Vba dictionary" there are lots of very good websites describing what dictionaries are and how to use them. I was planning to use a dictionary in a very simple way just to generate a unique list of names. I do this by adding all the names to the dictionary, if the name already exists it ignores it.
to check column 39 in the array in , just use 39 as the second index into inarr. e.g inarr(1,39) is the data in row 1 column 39
Your logic to select docyearname will stay the same.
to add the names to another array
' add just after the statement that loads inarr

Dim filenarr()
ReDim filenarr(1 To UBound(inarr, 1))

' then in the middle of the loop just after your logic ad

filenarr(i) = Docyearname ' this will load the array with the name for that row

I have written some code to show you a very basic use of a dictionary ( which is all you need) . Put a list of names in column A of a blank worksheet, make sure you have some duplicate names.
Then run this code, it adds the names to a dictionary and then loops through the dictionary to print each unique value to the immediate screen,
this is all the new stuff you need every thing else has already been covered in my code. I am already defining an output array and writing it to the worksheet. look at the use of out1 and out2
The sort remains the same

Sub test()
Dim dict As Object                              ' this line
Set dict = CreateObject("Scripting.Dictionary") ' these two line define a dictionary called dict
lastrow = Cells(Rows.Count, "A").End(xlUp).Row ' these two lines load the data in column A of
namarr = Range(Cells(1, 1), Cells(lastrow, 1)) 'the workhseet into a variant arrray called namarr

' this loop loop through the dsata in column A of the worksheet ( now copied into Namarr)
   For i = 1 To UBound(namarr, 1)
      dict(namarr(i, 1)) = namarr(i, 1)  ' this line of code creates entry in the dictionary
                                         ' with a key given by Namarr(i,1) , which is hte data in column A
                                         ' if the key doesn't exist it create the key
                                         ' So effectively this is creating a list of unique values from column
   Next i

' this code is just to show you what is in the dictionary:
noitems = dict.Count
Debug.Print " Number of items in dictionary " & noitems
Dim key As Variant
For Each key In dict.Keys
    Debug.Print key
Next key
End Sub

 

[dpaton05]

I was planning to use a dictionary in a very simple way just to generate a unique list of names. I do this by adding all the names to the dictionary,

What names were you going to add to the dictionary?

 

[dpaton05]

I think I get it now, the names to add to the dictionary.

I tried to write some code for the guidelines you put in post 42 and this is all I got

Sub cmdCopy()
    Dim ReportTrackingDictionary As Object, LastRow As Long, inarr As Variant, i As Long
    Set ReportTrackingDictionary = CreateObject("Scripting.dictionary")
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value
    For i = 1 To UBound(inarr, 1)
        ReportTrackingDictionary(inarr(i, 39)) = inarr(i, 1)
    Next i
    Dim site As String
    site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    
    For i = 1 To UBound(inarr, 1)
        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
    
        Dim DocYearNameDictionary As Object
        Set DocYearNameDictionary = CreateObject("scripting.dictionary")
            For i = 1 To UBound(inarr, 1)
                DocYearNameDictionary(DocYearName) = inarr(i, 1)
            Next i
    Next i
    
    
    
    
  
    
End Sub

I tried to write the code this code and the code that goes after this but I just couldn't work out what to write after the last next i, and I am not even sure if the code I wrote is correct. If you have time, can you help me with it and the remainder of the code please?



Thank you, I really appreciate this help as I am not very good at coding!!

 

[offthelip]

that code looks exactly what I was expecting, well done!!
the next steps are:

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)

In my dictionary example I showed you how to set up loop to loop through all items in a dictionary:

Dim key As Variant
For Each key In dict.Keys
    Debug.Print key
Next key

 

[dpaton05]

Thankyou. It's funny that I got that right as i was doing it really fast, half expecting Bits of it to be wrong.

So after the last next i, do I include?

Dim RTkey As Variant
For Each RTkey In ReportTrackingDictionary.Keys
    Debug.Print RTkey
Next RTkey

I think this is the loop but I didn't know what to include where the code says debug.print.

 

[offthelip]

In the outer loop first you open the filename which is given by the key RTkey, you already have the code to open the software. Then you set up a loop to go through inarr row by row.
There is one major difference now in this loop instead of writing the the results out to the worksheet every iteration , you write the results to another variant array . Just like I did with the out1 and out2, except this time you are going to write multiple rows to the arrays and only write it out when the loop is complete. So you need to change the definition of the output array to make it big enough to cope with all the rows that you write to it. So what i would do is declare the output array with the same number of rows as the input array then you know it will be big enough ( it doesn't matter if it is larger) . You need to keep a separate index to keep track of where the next blank row is on the output . So set up and index starting a 1 or 2 and increment each time you write a complete row out.
When you have done one file the outloop will take you to the second file.

 

[dpaton05]

So, this is the whole procedure so far:

Sub cmdCopy()
    Dim ReportTrackingDictionary As Object, LastRow As Long, inarr As Variant, i As Long
    Set ReportTrackingDictionary = CreateObject("Scripting.dictionary")
        For i = 1 To UBound(inarr, 1)
            ReportTrackingDictionary(inarr(i, 39)) = inarr(i, 1)
        Next i
        
    Dim site As String
    site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value
    For i = 1 To UBound(inarr, 1)
        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
    
        Dim DocYearNameDictionary As Object
        Set DocYearNameDictionary = CreateObject("scripting.dictionary")
            For i = 1 To UBound(inarr, 1)
                DocYearNameDictionary(DocYearName) = inarr(i, 1)
            Next i
    Next i
    
    Dim RTkey As Variant
    For Each RTkey In ReportTrackingDictionary.Keys
        If Not isFileOpen(RTkey & ".xlsm") Then Workbooks.Open ThisWorkbook.Path _
        & "\" & "Report Tracking" & "\" & site & "\" & RTkey & ".xlsm"
            For i = 1 To UBound(inarr, 1)


            I am not sure what goes here???

                 
            Next i
    Next RTkey
    
    
    
    

End Sub

I think I got that I needed a report tracking loop to open the report tracking files, but then I just got lost.

There is one major difference now in this loop instead of writing the the results out to the worksheet every iteration , you write the results to another variant array . Just like I did with the out1 and out2, except this time you are going to write multiple rows to the arrays and only write it out when the loop is complete

I didn't really understand what you did with out1 and out2

I think I need to back up a bit and make sure i have my understanding correct on all the code so far.

With this code

        With wsTrack
           lasttrack = .Cells(Rows.Count, "A").End(xlUp).Row + 1 ' find the next empty row on the wstrack sheet

            .Range(.Cells(lasttrack, 1), .Cells(lasttrack, 1)) = inarr(i, 1)
            ' copy the 4th column of this row from tblcosting to the 1st column of the output array
            out1(1, 1) = inarr(i, 4)
            ' copy the 5th column of this row from tblcosting to the 2nd column of the output array
            out1(1, 2) = inarr(i, 5)
            ' copy the small output array to the worksheet on row lasttrack
            .Range(.Cells(lasttrack, 2), .Cells(lasttrack, 3)) = out1
        End With

What does this line of code do?

.Range(.Cells(lasttrack, 1), .Cells(lasttrack, 1)) = inarr(i, 1)

I think I also need the date copied across too. It is stored in column 1 in tblCosting. Would I just need to change the following?

            out1(1, 1) = inarr(i, 1)
            out1(1, 2) = inarr(i, 4)
            out1(1, 3) = inarr(i, 5)

I am sorry I am so slow to understand things.


Thanks for your patience.

 

[offthelip]

I have updated your code to show you the next steps and added some comments to point out some things that need correcting.
I did come up with another question. I notice that in the reporttracking workbook , the worksheet the results need to be written to are defined in variable "combo" which is loaded form column 26. Does this change with the workbook or does it change independently of the workbook. The reason I ask is if one particular workbook always writes to the same worksheet then it is much simpler. However it it changes independent of the workbook then we need to set up another dictionary and another control loop
updated code:

Sub cmdCopy3()

    Dim ReportTrackingDictionary As Object, LastRow As Long, inarr As Variant, i As Long
  ' comment define output array but the size of it is defined later
    Dim outcolA()
    Dim outcolDE()
'comment : this section of code uses "inarr" as onme of the variables
'so it must go AFTER you have loaded inarr from the tblecostng
    Set ReportTrackingDictionary = CreateObject("Scripting.dictionary")
        For i = 1 To UBound(inarr, 1)
            ReportTrackingDictionary(inarr(i, 39)) = inarr(i, 1)
        Next i
'comment:  end of section
    Dim site As String
    site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    ' Comment: this is where inarr is loaded
    inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value
    ' comment now we know the size ofthe input array we can defein the size of the output arrays
    ' because we know they can't be larger than the input array. both have the same number of rows as the input table
    ReDim outcolA(1 To UBound(inarr, 1), 1 To 1) ' this is one column wide
    ReDim outcolDE(1 To UBound(inarr, 1), 1 To 2) ' this is two columns wide
    For i = 1 To UBound(inarr, 1)
        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
   
        Dim DocYearNameDictionary As Object
        Set DocYearNameDictionary = CreateObject("scripting.dictionary")
            For i = 1 To UBound(inarr, 1)
                DocYearNameDictionary(DocYearName) = inarr(i, 1)
            Next i
    Next i
   
    Dim RTkey As Variant
    For Each RTkey In ReportTrackingDictionary.Keys
        If Not isFileOpen(RTkey & ".xlsm") Then Workbooks.Open ThisWorkbook.Path _
        & "\" & "Report Tracking" & "\" & site & "\" & RTkey & ".xlsm"
            ' commnet set up index for output array
            indi = 1
            For i = 1 To UBound(inarr, 1)
            ' comment check to see if this line of tblcosting needs to be written to the file we have got open
               If inarr(i, 39) = RTkey Then
                 ' write the data out to the output array
            I am not sure what goes here???
                  outcolA(indi, 1) = inarr(i, 1) 'this copies the first column in the tblCosting to col A
                  outcolDE(indi, 1) = inarr(i, 4) 'this copies the 4th column in the tblCosting to Col D
                  outcolDE(indi, 2) = inarr(i, 5) 'this copies the 5th column in the tblCosting to Col E
                   ' increment the output index
                  indi = indi + 1
               End If
            Next i
           ' write the output array to worksheet
          
    Next RTkey
   
   
   
   

End Sub

 

[offthelip]

.Range(.Cells(lasttrack, 1), .Cells(lasttrack, 1)) = inarr(i, 1)

this line of code copies the value which came from the first column of tblcosting row number given by i ( which is now sitting in inarr) into Column A row number given by lasttrack

I think I also need the date copied across too. It is stored in column 1 in tblCosting. Would I just need to change the following?

column 1 of tblcosting is now in inarr(i,1) so you are already copying it with this line of code:

out1(1, 1) = inarr(i, 1)

( and the one in the first line of this comment!!)